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PREFACE 


This  report  was  prepared  by  Sierra  Geophysics,  Inc.,  Redmond,  Washington,  under 
Contract  F08635-82-C-0374,  for  the  Air  Force  Engineering  and  Services  Center, 
Environics  Division  (AFESC/RDV) ,  Tyndall  Air  Force  Base,  Florida.  Major  Gary  Worley 
was  the  AFESC  project  Director;  the  Project  Leader  at  Sierra  Geophysics  was  Daniel 
Bleeker,  assisted  by  Gary  Garrabrant. 

The  primary  objective  of  the  work  carried  out  on  this  project  between  July  1982 
and  December  1983  was  to  place  on  an  Air  Force  microcomputer  the  procedures  that 
were  heretofore  performed  manually  to  predict  the  hazard  corridor  associated  with  a 
toxic  propellant  release.  Computer  hardware  specifications  were  established  which 
allow  for  expanded  dispersion  modeling  techniques,  and  follow-on  efforts  are  under¬ 
way  to  upgrade  the  software  contained  in  appendices  to  this  report. 

The  use  of  certain  computer  equipment  in  this  project  does  not  constitute  an 
endorsement  of  these  products  by  the  Air  Force,  and  the  views  and  conclusions 
contained  in  this  document  are  those  of  the  authors  and  should  not  be  interpreted 
as  necessarily  representing  official  policy,  either  expressed  or  implied,  of  the 
Air  Force  or  the  United  States  Government. 


This  report  has  been  reviewed  by  the  Public  Affairs  Office  (PA)  and  is  releasable 
to  the  National  Technical  Information  Service  (NTIS) .  At  NTIS  it  will  be  available 
to  the  general  public,  including  foreign  nationals. 
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SECTION  I 


INTRODUCTION 


When  a  toxic  chemical  is  vented  to  the  atmosphere,  an  estimate  of 
the  extent  of  the  affected  area,  or  "toxic  corridor"  must  be  made.  The 
size  of  the  toxic  corridor  depends  upon  the  release  rate  of  the  toxic 
chemical,  the  concentration  exposure  limits  for  the  chemical  and  the 
dispersive  properties  of  the  atmosphere  at  the  time  of  release.  Four 
methods  of  producing  toxic  corridor  estimates,  ranging  from  table  look¬ 
up  to  programmable  calculator  techniques,  have  been  described  in 
previous  work  (Reference  1).  This  report  describes  a  fifth  approach: 
the  use  of  a  microcomputer  system  which  encompasses  crucial  support 
functions,  in  addition  to  toxic  corridor  computations,  and  thereby 
expedites  overall  emergency  response. 


The  primary  goal  of  the  computerized  Real-Time  Modeling  System 
(RTMS)  is  to  separate  the  tasks  suitable  for  execution  on  a  computer 
system  from  those  which  must  be  performed  by  an  emergency  response 
specialist.  Figure  1  presents  the  basic  tasks  involved  in  toxic  corridor 
calculations.  The  RTMS  consolidates  thf  data  manipulation,  toxic 
corridor  computations,  and  plotting  functions,  allowing  more  time  for 
subjective  analysis  of  the  results  of  the  toxic  corridor  calculations. 

The  RTMS  consolidates  information  pertinent  to  a  toxic  chemical 
release,  as  shown  by  Figure  2.  Critical  meteorological  parameters  and 
information  about  the  toxic  chemical  are  simultaneously  displayed,  aiding 
user  analysis.  The  flexible  nature  of  the  RTMS  allows  inclusion  of 
additional  information  in  the  graphic  display  to  meet  special 
requirements. 
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Figure  1.  Toxic  Corridor  Development 


TOXIC  CORRIDOR  INFORMATION  TIME:  17:36:15 

DATE:  10/19/83 


SUBSTANCE:  OXIDIZER 

SOURCE  :  PRESSURE  DRAIN  FIXED  SYSTEM  STG  I&II 
SOURCE  STRENGTH  (#/MIN) :  5.00 


METEOROLOGICAL  DATA 


WIND  SPEED . 

WIND  DIRECTION. 
SIGMA  THETA.... 
DELTA  T . 

(KTS) : 
(DEG)  : 
(DEG) : 
..(F): 

20.  0 
£70.  0 

12.  0 
-1.0 

CORRIDOR 

DIRECTION. 

(DEG) : 

90.0 

CORRIDOR 

WIDTH . 

(DEG) : 

7£.  0 

CORRIDOR  LENGTH 

(FEET) 

SPEL 

(PPM) 

OB/DG 

(DELTA  T) 

OB/DG 

(SIGMA  THETA) 

10  MIN 

5.0 

777.6 

719.  3 

30  MIN 

3.0 

1010. 5 

933.  4 

60  MIN 

£.0 

1244.2 

1147.8 

Figure  2.  Toxic  Corridor  Information  Display 
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SECTION  II 


DESCRIPTION  OF  THE  RTMS 


The  following  sections  describe  the  function  of  each  major  module 
of  the  RTMS.  Figure  3  represents  a  block  diagram  showing  the 
interrelationship  of  each  module. 


A.  COMMAND  AND  CONTROL  MODULE  (CCM) 


The  CCM  is  the  primary  user  interface  with  the  RTMS.  Each  of 
the  six  functional  areas  shown  in  Figure  3  is  accessed  via  a  menu 
presented  by  the  CCM. 


B.  EVENT  ARCHIVE  MODE 


When  the  Event  Archive  Mode  is  selected,  the  results  of  all 
subsequent  toxic  corridor  calculations  are  stored  on  the  system  in  an 
archive  file.  The  Event  Archive  mode  provides  a  chronological 
history  of  all  events,  including  the  time  and  date  of  each  calculation. 


C.  RECALL  EVENT  ARCHIVE 


The  Recall  Event  Archive  utility  provides  the  user  with  a  list  of 
stored  event  archive  data.  Users  may  select  any  of  the  stored  event 
data  for  display  and/or  printing. 
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D.  TOXIC  CORRIDOR  CALCULATION  MODULE  (TCCM) 


Toxic  corridor  lengths  are  calculated  .based  on  the  Ocean  Breeze/ 
Dry  Gulch  equation  (Reference  1): 


X  =  P  [3.28  (%”)  0.533  (ce)-0-5>3  ' 


where  X  =  downwind  distance  from  the  source  in  feet.  As 

used  here,  this  distance  defines  the  toxic  corridor 
length. 

P  =  a  probability  factor  based  upon  the  probability 
that  a  specified  concentration  is  not  exceeded 
outside  the  corridor.  Calculations  in  Kahler 
and  others  (Reference  1)  assume  a  90  percent 
probability  with  P  equal  to  1.63. 


GMW  =  gram  molecular  weight  of  the  toxic  chemical. 

Cp  =  peak  concentration  in  parts  per  million  by  volume 

(PPM)  along  a  plume  centerline  and  at  a  height  of 
approximately  5  feet  above  the  ground  at  a  given 
downwind  travel  distance,  X,  in  feet.  Toxic 

corridor  lengths  are  calculated  by  using  a  specified 
exposure  limit  for  Cp  in  the  above  equation. 

Q  =  source  strength  in  Ib/min. 

AT  =  the  temperature  in  °F  at  54  feet  minus  the 

temperature  at  6  feet  (NOTE:  A  negative  AT  means 
a  decrease  of  temperature  with  height  and  a 
positive  AT  means  an  increase  with  height.) 


Values  for  GMW,  CP,  and  Q  may  be  obtained  from  the  RTMS  data  base 
or  entered  by  the  user.  Three  values  are  used  for  peak  concentration, 
corresponding  to  the  10- ,  30-  and  60-minute  exposures  of  a  given  toxic 
substance.  A  value  for  AT  must  be  suppled  by  the  user.  Validity 
checks  are  performed  on  the  data,  then  corridor  lengths  for  appropriate 
concentration  levels  are  calculated. 

If  the  wind  speed  is  greater  than  or  equal  to  3  knots,  the  corridor 
direction  is  determined  from  the  wind  direction  entered  by  the  user. 
The  corridor  width  is  set  to  6  06  (oft  is  the  standard  deviation  of  the 
horizontal  wind  direction).  The  width  is  set  to  360  degrees  if  the  wind 
speed  is  less  than  3  knots. 


A  simplified  algorithm  for  computing  source  strengths  due  to  toxic 
chemical  spills  (Reference  2)  is  available  under  the  TCCM.  If  the  spill 
option  is  selected,  the  user  enters  information  concerning  the  size  of 
the  spill  (square  feet  of  area  covered)  and  the  temperature  of  the  pool. 
A  source  strength  is  calculated  and  the  TCCM  computes  corridor  width 
and  lengths.  Figure  2  shows  the  typical  output  from  the  TCCM. 


E.  DATA  BASE  MANAGEMENT  MODULE  (DBMM) 


Two  distinct  types  of  information  are  maintained  by  the  DBMM: 
(1)  Source-substance  data  and  (2)  Procedural  information. 
Source-substance  data  include  specific  values  for  source  and  substance 
parameters  necessary  for  toxic  corridor  calculations.  A  full  description 
of  the  source-substance  data  base  is  available  in  Appendix  A.  The 
procedural  data  are  of  a  documentary  nature,  providing  the  RTMS  user 
access  to  background  information  while  executing  the  RTMS.  For 
example,  the  user  may,  while  running  the  RTMS  program,  display 
detailed  information  concerning  the  Ocean  Breeze/Dry  Gulch  equation. 
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The  DBMM  provides  the  user  with  the  means  of  searching, 
modifying,  adding  to,  and  deleting  from  the  source-substance  and 
procedural  data  bases. 


F.  TIME 

The  "time"  utility  allows  the  user  to  display  current  time,  as 
determined  by  the  computer  system  which  is  host  to  the  RTMS. 


G.  HELP 

The  entire  RTMS  program  is  self-documenting.  The  "help"  utility 
presents  the  user  with  a  description  of  each  of  the  options  presented  in 
the  selection  menu. 


SECTION  III 


IMPLEMENTATION  OF  THE  RTMS 


The  RTMS,  as  described  here,  is  implemented  on  a  Cromemco  68000 
computer  system,  operating  under  the  CROMIX  multiuser  operating 
system.  The  basic  components  of  the  computer  system  are  shown  in 
Figure  4  and  detailed  specifications  are  listed  in  Table  1. 


The  RTMS  is  programmed  entirely  in  FORTRAN  77  (as  implemented 
under  the  CROMIX  operating  system).  For  details  on  the  specifics  of 
the  FORTRAN  77,  one  should  consult  the  Cromemco  68000  FORTRAN  77 
manual.  Complete  program  listings  for  the  RTMS  are  available  in 
Appendix  B. 


A.  STRUCTURE  OF  THE  RTMS  PROGRAM 

The  RTMS  is  composed  of  two  types  of  program  modules: 
(1)  high-level  routines  designed  for  performing  the  primary  tasks  of 
data  base  management,  toxic  corridor  calculation,  etc.,  and  (2) 
low-level  routines  for  menu  display  and  command  processing.  The 
high-level  routines  are  functionally  grouped  to  perform  the  primary 
tasks  described  in  Section  II  of  this  report.  The  low-level  routines  are 
used  as  required  for  display  and  command  processing  by  any  of  the 
high-level  routines. 


The  demarkation  between  high-  and  low-level  routines  greatly 
facilitates  transporting  the  RTMS  software  between  computer  systems. 
The  RTMS  software  may  be  fully  implemented  on  a  host  computer 
system,  given  adequate  random  access  memory  and  a  FORTRAN  77 
compiler,  with  relatively  minor  changes  to  the  low-level  routines. 
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PRINTER 


TABLE  1 


RTMS  SYSTEM  SPECIFICATIONS 


Computer 


Cromemco  68000/Z80  Computer 
CROMIX  Operating  System 

512  Kilobytes  of  Random  Access  Memory  (RAM) 

2  -  5.25-Inch  Floppy  Disk  Drives 

1  -  20-Million  Byte  Rigid  Disk  Drive 
FORTRAN  77  Software 

3  -  RS232  Serial  I/O  Ports 

1  -  Parallel  Port  (for  the  printer) 


2.  Printer 


132-Column  Dot  Matrix  Printer  with  a  Parallel  Interface 


3.  Plotter 


8-Pen  Plotter  with  a  Serial  Interface 


B.  OPERATION  OF  THE  RTMS 


The  RTMS  program  is  self-documented,  via  "help"  files.  The  "help" 
information  is  intended  to  aid  the  inexperienced  person  in  effectively 
using  the  RTMS.  Help  is  available  to  the  user  as  a  menu  option  and  is 
therefore  available  during  the  operation  of  RTMS. 


C.  RTMS  OUTPUT 


Several  types  of  output  are  available  from  the  current  version  of 
RTMS.  A  tabular  display  (shown  previously  in  Figure  2)  contains  a  sum¬ 
mary  of  the  input  data,  output  data  and  other  pertinent  information  from 
the  source-substance  data  base  that  was  used  in  the  calculation.  This 
summary  can  be  directed  from  the  CRT  to  a  printer,  or  it  can  be  routed 
to  a  communications  terminal. 


A  graphical  display,  as  shown  in  Figure  5,  is  directed  to  the  plot¬ 
ter.  The  hazard  corridor  can  be  plotted  at  a  specified  location  on  a 
digitized  map  from  the  data  base,  or  the  plot  can  serve  as  an  overlay 
onto  any  base  map  of  an  appropriate  scale. 
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SECTION  IV 


CONCLUSIONS 


The  RTMS  fulfills  its  primary  requirement  of  streamlining  the  toxic 
corridor  calculations  requirement  by  consolidating  the  data  required  to 
perform  the  corridor  computations.  Additional  benefits  derive  from  the 
archive  mode  of  the  RTMS,  which  provides  automatic  record  keeping  of 
all  corridor  determinations,  and  from  the  maintenance  of 
source-substance  and  procedural  data  bases.  The  RTMS  is  fully 
menu-driven  and  provides  on-line  "help"  information,  facilitating  system 
use  by  those  unfamiliar  with  its  operation. 


A  valuable  enhancement  to  the  existing  RTMS  will  be  the  inclusion 
of  interactive  color  graphics  capabilities.  The  graphics  capabilities  will 
allow  users  to  interact  with  the  RTMS  via  displayed  maps  and  pictorial 
representations  of  the  data  bases. 


The  RTMS,  as  developed,  is  oriented  towards  supporting  TITAN  II 
operations,  but  provides  the  framework  for  a  much  broader  application. 
The  data  base  capability  is  being  extended  to  support  a  complete 
inventory  of  toxic  substances  for  an  arbitrary  location,  and  the  toxic 
corridor  calculation  module  is  being  enhanced  with  a  more  advanced  air 
dispersion  model.  Additional  capabilities  could  be  added,  ultimately 
resulting  in  a  fully  integrated  emergency  response  and  toxic  substance 
record-keeping  system. 
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APPENDIX  A 


A.  PROCEDURE  DATA  BASE 


The  procedure  data  base  consists  of  an  unformatted  direct  access 
file  with  a  logical  record  length  of  48  bytes.  This  file  is  called  the 
procedure  header  file  (PH  file).  The  first  record  in  this  file  contains  a 
4-byte  integer  which  indicates  how  many  records  are  in  the  file.  The 
remainder  of  the  records  take  the  form  shown  in  Figure  A1 . 


The  40-character  procedure  name  or  description  field  is  used  as  a 
key  to  identify  each  procedure.  The  actual  name  of  the  disk  file  in 
which  the  text  for  a  procedure  is  contained  is  in  the  last  eight 
characters  of  the  record.  These  file  names  take  the  form  PROCXXX 
where  XXX  ranges  between  000  and  099. 


The  PROCXXX  files  are  sequential  formatted  files  whose  logical 
record  length  is  80  bytes.  These  files  contain  the  actual  text  about 
any  procedure  which  is  on  file. 


B.  SUBSTANCE-SOURCE  DATA  BASE 


The  Substance-Source  Data  base  is  made  up  of  four  direct  access 
unformatted  files.  The  four  file  types  are:  Substance,  Source,  Pointer 
and  Data.  The  relationship  between  the  DBMM  and  the  Substance-Source 
Data  base  is  shown  by  Figure  A2. 
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Fiqure  Al.  rroccduro  Data  nase  file  structure? 


Figure  A2.  DBMM  and  the  Substance-Source  Data  Base 


The  record  length  for  the  Source  File  is  40  bytes.  The  first  record  is 
a  header  record  and  contains  a  counter  that  indicates  how  many  records 
are  in  the  file.  The  counter  is  a  4-byte  integer.  The  rest  of  the 
records  take  the  form  shown  in  Figure  A3.  The  source  name  is  stored 
in  the  file  as  indicated  in  Figure  A3. 

The  Substance  File  has  a  logical  record  length  of  120  bytes.  The 
first  40  bytes  are  used  to  store  the  substance  name.  Since  many  of  the 
quantities  of  interest  are  substance-related,  they  are  stored  in  the 
substance  record.  The  Substance  File  also  has  a  header  record  which 
holds  a  4-byte  integer  counter  to  indicate  the  number  of  records  in  the 
file,  including  the  header  record.  The  last  40  bytes  of  the  record  hold 
ten  4-byte  real  numbers.  They  are  the  gram  molecular  weight  (GMW), 
the  10- ,  30-  and  60-minute  public  emergency  limits,  the  Z  factor  and 
five  extra  locations  for  future  expansion.  All  of  these  data  are  part  of 
the  substance  records  as  shown  in  Figure  A3.  The  middle  40  bytes 
contain  ten  4-byte  integers.  The  first  9  are  pointers  into  the  source 
file  and  the  10th  pointer  points  into  the  substance  file.  Each  substance 
record  is  allowed  to  point  to  9  sources.  The  first  9  pointers  are  record 
numbers  into  the  source  file.  These  pointers  indicate  which  sources 
the  substance  is  linked  to.  Since  a  substance  may  be  linked  to  more 
than  nine  sources,  there  may  be  more  than  one  substance  (of  a 
particular  kind)  record  in  the  substance  file.  The  10th  pointer  points 
to  the  next  record  in  the  substance  file  for  the  same  substance  (or  the 
pointer  has  a  zero  value).  This  allows  the  substances  to  be 
forward-linked  in  the  substance  file. 

The  Pointer  File  is  easy  to  explain,  but  a  little  harder  to 
understand.  The  Pointer  File  record  length  is  40  bytes.  It  does  not 
contain  a  header  record.  However,  for  uniformity  with  the  other  files 
the  first  record  must  be  skipped.  The  rest  of  the  records  have  the 
form  shown  on  Figure  A3.  Each  record  consists  of  ten  4-byte  integers. 
The  last  integer  is  extra,  only  the  first  9  are  used.  The  pointers 
point  into  the  data  file.  The  ith  record  and  ith  pointer  in  that  record 
correspond  to  the  ith  substance  and  ith  source  pointer  in  the  substance 


SUBSTANCE  FILE  RECORD 


0 

VHIX3 


0 

VdiX3 


0 

VdlX  3 


0 

VdiX3 


0 

Vdix3 


dOiOVJ  2 


134  NIK  09 


13d  NIK  OC 


13d  NIK  01 


MK9 


d3iN lOd 
30NVlS8nS 


€  d  3 1  N  tOd 

3  Od nos 


8  d3lN  lOd 
3DM00S 

l  d3lNlOd 
3  OdOOS 

9  d3lN  lOd 

3onnos 


5  d  3  1  N  lOd 

30«nos 


>  d31NlOd 
33800$ 


C  dSINIOd 
338005 


2  83iNI0d 
aodnos 


I  dllNIOd 
33800$ 


UJ 

O 

2 

< 

CO  UJ 
00  2 
=)  < 
00  2 


CO 

< 

UJ 

ir 


UJ 


oo 

<r 

UJ 

K 

o 

< 

cc 

< 

X 

o 

o 


Vd  1X3 

6  d3  INlOd 
VIVO 

8  d31  N  lOd 

viva 

0 

0 

1 

0 

c 

1 

o 

1  dSINIOd 

vivo 

o 

UJ 

H 

cc 

o 

o 

8  d  31  NlOd 
VIVO 

2 

it  i 

UJ 

cr 

$  dSINIOd 
VIVO 

UJ 

h* 

>- 

CD 

UJ 

-j 

t  uaiNiOd 
VIVO 

u. 

cc 

fi  dilNIOd 
VIVO 

c. 

UJ 

1- 

2 

l  dilNIOd 

viva 

o 

a. 

1  U3lNIOd 
VIVO 

_ 

o 

£E 

o 

u 

UJ 

31Vd  M0*ld 

CO 

LL. 

otnon 

-J 

< 

UJ 

iiiiNvno 

UJ 

cr 

_j 

nvioi 

u. 

UJ 

LL. 

H 

< 

NOIlVdflQ 

I 

H 

M19N3W1S 

* 

O 

ion not 

21 


Figure  A3.  Substance -Source  Data  Base  Structures. 


record  of  interest.  The  pointer  in  the  pointer  record  points  to  the 
record  number  in  the  data  file  that  contains  the  source  strength, 
duration,  total  quantity  and  liquid  flow  rate  for  a  particular 
substance-source  pair. 

The  Data  File  logical  record  length  is  16  bytes.  As  before,  the 
data  file  contains  a  header  record.  The  header  record  contains  a 
4-byte  integer  counter  which  indicates  the  number  of  records  in  the 
file.  The  data  stored  in  each  record  are  source  strength,  duration, 
total  quantity  and  liquid  flow  rate  for  a  particular  substance- source. 
The  word  locations  are  shown  in  Figure  A3. 
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n  n 


$BIGCODE 

PROGRAM  CCM 


C******************************************************************* 

C  THIS  IS  THE  MAIN  DRIVING  PROGRAM  FOR  TOXIC  CORRIDOR 
C  CALCULATIONS.  THIS  PROGRAM  PRODUCES  A  MENU  TO  SELECT 
C  WHICH  OF  THE  MODULES,  TCCM,  DBCM,  ...  IS  TO  BE  EXECUTED. 

C  ! ! '  WARNING  1 ! !  DO  NOT  USE  UNIT  15  IN  SYSPARM  FILE,  IT  IS  RESERVED 
C  FOR  THE  PRINTER 

r 

C  VARIABLES  USED 


c 

ITR 

- 

INTERACTIVE  TERMINAL  READ  UNIT 

c 

AUNIT 

- 

UNIT  FOR  ARCHIVE  FILES 

c 

AUNIT 1 

- 

UNIT  FOR  RECALLED  ARCHIVE  FILES 

c 

HFILE 

- 

SYSTEM  HELP  FILE  NAME 

c 

HUN  IT 

- 

UNIT  FOR  SYSTEM  HELP  FILE 

c 

SFILE1 

- 

SUBSTANCE  FILE  NAME  (SUBSTANCE-SOURCE  DATA  BASE) 

c 

SFILE2 

- 

SOURCE 

II 

c 

SFILE3 

- 

POINTER 

II 

c 

SFILE4 

- 

SOURCE  DATA  FILE  NAME 

II 

c 

SUNIT1 

- 

UNIT  FOR  SFILE1 

c 

SUNIT2 

- 

"  "  SFILE2 

c 

SUNIT3 

- 

"  "  SFILE3 

c 

SUNIT4 

- 

"  "  SFILE4 

c 

SHFILE 

- 

SUBSTANCE-SOURCE  HELP  FILE  NAME 

c 

PFILE1 

- 

PROCEDURE  HEADER  FILE  NAME  (PROCEDURE 

DATA  BASE) 

c 

PUNIT1 

- 

UNIT  FOR  PFILE1 

c 

PHFILE 

- 

PROCEDURE  HELP  FILE  NAME 

c 

SMFILE 

- 

MENU  FILE  NAME 

c 

SMUNIT 

- 

UNIT  FOR  SMFILE 

c 

BFILE 

- 

CROMIX  DIRECTORY  WHERE  ARCHIVE  FILES  ARE  STORED 

c 

BUNIT 

- 

UNIT  FOR  OPENING  CROMIX  FILE  DIRECTORY 

LIST.  USED 

c 

TO  ESTABLISH  A  LIST  OF  AVAILABLE  EVENT 

ARCHIVE  FILES 

c 

MFILE 

- 

MAP  DATA  BASE  HEADER  FILE  NAME 

c 

MUNIT 

- 

UNIT  FOR  MFILE 

C********************************************************************* 

c 


CHARACTER*40  BFILE 
CHARACTER*!  CMD<1) 
CHARACTER* 15 
CHARACTER*? 


INTEGER 


LOGICAL 


STAMP 

AFILE,  CFILE,  SFILE1 ,  SFILE2, SFILE3, SFILE4, MFILE, 
HFILE,  SHFILE,  PFILE1, PHFILE, SMFILE 


ITR, AUNIT, AUNIT1, HUN IT, SUNIT1 , SUNIT2, SUNIT3, SUNIT4, 
CUNIT, PUNIT1, PUNIT2, SMUNIT, RC (2, 3) ,  BUNIT,  MUNIT 

AFLAG, MREAD 


COMMON/MENUS/MREAD 


CHECK  FOR  THE  SYSTEM  FILE  SYSPARM.  IF  IT  DOESN’T  EXIST  THEN 
EXIT  THE  PROGRAM. 

INQUIRE  <FILE=’ SYSPARM’ , EXIST=AFLAG> 

IF  (.NOT.  AFLAG)  THEN 
CALL  CLEAR (7,0) 

CALL  MENUDR(’ SYSTEM  FILE  NOT  FOUND’ , 12, 30, 2, 0,  1, 1 ) 

CALL  MENIJDRP  ’,24,1,2,0,1,1) 

STOP 


END  IF 
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nr  n  nwon  ron 


C  USER  INPUT  VALID,  CALL  ROUTINE  TO  DISPLAY  THE  FILE 

CALL  PROREV  < ITR, TEMP,  AUNIT) 

C  GO  BACK  AND  DISPLAY  THE  MAIN  MENU 

GOTO  100 

END  IF 

C  INCREMENT  THE  COUNTER  WHICH  TELLS  HOW  MANY  ARCHIVE  FILES  HAVE  BEEN  FOUND 
CNT=CNT+1 
GOTO  20 

END  OF  FILE  REACHED  IN  ARFILE 
IF  ((FLAGl).AND. (.NOT.  FLAG2) >  THEN 

CLOSE  (BUNIT) 

GOTO  15 
END  IF 

IF  < (FLAG1 ) . AND. (FLAG2) ) 

*  CALL  MESS (17,  RC (£0,  1 ) ,  RC  <20, 2) , RC  <20, 3) , 7) 

THERE  WERE  NOT  19  FILES  TO  DISPLAY,  ONLY  CNT-1  TO  DISPLAY 
CALL  MENUWR (RC, £0, 2, CNT-1, OUT, 0, 2, ST) 

INPUT  THE  USER  OPTION 
INP  < 1 ) =  '  * 

CALL  MENURD(RC, 20, 1, 1, INP,  ITR) 

USER  SELECTED  TO  RETURN,  SO  CLOSE  THE  LISTING  FILE 
IF  (INP<1)  .EQ.  ’X  ’)  THEN 

CLOSE  (BUNIT) 

RETURN 
END  IF 

USER  CHOOSE  TO  CONTINUE 
IF  ( INP ( 1 )  .EQ.  ’C  ’)  THEN 
CLOSE  (BUNIT) 

FLAG1*. TRUE. 

CALL  MENUSV (SMFILE,  1 15, RC,  20,  SMUNI  T) 

GOTO  15 

END  IF 

USER  SELECTED  A  NUMBER,  MAYBE.  CHECK  TO  SEE  IF  VALID  INPUT  AND  TRY 
TO  OPEN  THE  ARCHIVE  FILE 
READ ( INP, ’ (BN, 13) ’ , ERR=35)  JJ 

C  FORM  THE  ARCHIVE  FILE  NAME  INCLUDING  THE  DIRECTORY  PREFIX 
AF I LE=EF I LE ( J J ) 

FNAME(l) (1 s47)=BFILE 
FNAME(l) (41s  47) =AFILE 
TEMP=FNAME ( 1 ) 

CALL  PACK (TEMP, J) 

INQUIRE  (FILE=TEMP, EXIST=FLAG3) 

IF  (.NOT.  FLAG3)  GOTO  35 

C  VALID  USER  INPUT,  DISPLAY  THE  ARCHIVE  FILE 
CALL  PROREV (ITR, TEMP, AUNIT) 

CLOSE  (BUNIT) 

C  GO  BACK  AND  DISPLAY  THE  MAIN  MENU 
GOTO  100 
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END 

SUBROUTINE  PROREV ( ITR,  AFILE, AUN I T ) 

C***********************#****#****#*********#«**«************************** 
C  PROREV  DISPLAYS  THE  LIST  OF  AVAILABLE  ARCHIVE  FILES  ON  THE  SCREEN 

C  22  LINES  AT  A  TIME 

C 

C  VARIABLES  ITR,  AFILE  AND  AUNIT  ARE  DESCRIBED  IN  SUBROUTINE  REVENT 

C 

C  INTERNAL  FLAGS: 

C  FLAG1  -  TRUE  :  THE  SCREEN  SHOULD  BE  CLEARED 

C  FALSE:  THE  SCREEN  SHOULD  NOT  BE  CLEARED 

C  FLAGS  -  TRUE  :  END  OF  FILE  REACHED 

C  -  FALSE:  NO  END  OF  FILE  REACHED 

C************************************************************************** 

CHARACTER*80  DLINE 
CHARACTER*47  AFILE 
CHARACTER* 1  INP ( 1 ) , FMFEED 

INTEGER  AUNIT,  RC(1, 3) 

LOGICAL  FLAG 1, FLAGS 

RC ( 1 , 1 ) =23 
RC ( 1 , S) =34 
RC ( 1 , 3) =1 

C  CLEAR  THE  SCREEN  AND  OPEN  THE  ARCHIVE  FILE  TO  BE  DISPLAYED 
rai  i  n  for  (7 

OPEN  (AUNIT, FILE=AFILE,  STATUS*’  OLD’  ) 

C  STRIP  OFF  THE  HEADER : ARCHIVE  FILE  ARCHXX  HH:MM:SS  MM/DD/YY 

READ (AUNIT, ’ (A80) ’ )  DLINE 

FLAGS*. FALSE. 

30  FLAG1=. TRUE. 

DO  10  1=1 , 22, 1 

READ(AUNIT, *  (A80)  ’  , END=14)  DLINE 
IF  (FLAG1 )  THEN 

FLAG1*. FALSE. 

CALL  CLEAR  (7,0) 

END  IF 

CALL  MENUDR (DLINE, I, 1,2,0, 1, 1) 

10  CONTINUE 

GOTO  15 

14  FLAGS*. TRUE. 

C  IF  END  OF  FILE  REACHED  DISPLAY  MESSAGE  TO  THAT  AFFECT 

15  IF  (FLAGS)  CALL  MENUDR (’END  OF  FILE  REACHED’ ,  £3,  62,  7,  0, 1,  1 ) 

CALL  MENUDR (’ SELECT  OPTION  (X  OR  C  OR  P)  ==>’,23,1,2,0,1,1)  ' 

C  INPUT  THE  USER  SELECTED  OPTION 

20  INP(1)=’  ’ 

CALL  MENURD (RC, 1, 1, 1, INP, ITR) 

C  USER  SELECTED  THE  RETURN  OPTION,  SO  CLOSE  FILE  AND  RETURN 

IF  ( INP  ( 1 )  .EQ.  ’X’)  THEN 

CLOSE  (AUNIT) 


RETURN 
END  IF 


C  USER  SELECTED  THE  PRINT  OPTION,  SO  PRINT  THE  FILE 
IF  ( INP  <  1 )  .EQ.  ’PM  THEN 

CLOSE (AUNIT) 

OPEN (PUN IT, FILE=AFILE, STATUS*’ OLD’ ) 

C  SET  THE  PRINTER  UP  WITH  FORM  FEED 

IFORM*  12 

FMFEED*  CHAR ( IFORM) 

OPEN ( 15, FILE*’  /DEV/PRT’  ) 

C  STRIP  OFF  THE  HEADER  RECORD 

READ (AUNIT, ’ (A80) * , END=220)  DLINE 
£00  CONTINUE 

C 


210 

GO  TO  200 

C  SEND  FORM  FEED  TO  CLEAR  PAGE,  CLOSE  UNITS 

£20  WRITE  < 15, ’  <A1 ) ’ )  FMFEED  • 

CLOSE (AUNIT) 

CLOSE (15) 

RETURN 
END  IF 


C  USER  SELECTED  TO  CONTINUE  VIEWING  ARCHIVE  FILE 
IF  ( INP  ( 1 )  .EQ.  ’CM  THEN 

IF  (FLAG2)  THEN 
CLOSE  (AUNIT) 

OPEN  (AUNIT, FILE-AFILE,  STATUS*’  OLD’  ) 

READ ( AUNIT, ’ (A80)* >  DLINE 
FLAG2*. FALSE. 

END  IF 

GOTO  30 
END  IF 

GOTO  20 
END 

INTEGER  FUNCTION  BNDX (STR, N) 

C****************************************************************************** 
C  THIS  FUNCTION  SCANS  A  CHARACTER  STRING  FROM  POSITION  N  TO.l  AND  RETURNS 

C  THE  FIRST  NON- BLANK  POSITION  ENCOUNTERED,  IF  NO  BLANKS  ARE  FOUND  A  1  IS 

C  RETURNED. 

C  VARIABLES  PASSED I 

C 

C  STR  -  CHARACTER  STRING  TO  BE  SEARCHED 

C  N  -  POSITION  OF  THE  STRING  TO  SEARCH  BACKWARD  FROM 

C 

C  VARIABLES  RETURNED: 

C 

C  BNDX  -  FIRST  NON -BLANK  POSITION  ENCOUNTERED  IN  THE  BACKWARD  SEARCH 

C#*#*#*#**************************##***#*######*#####***######**###**###*****#* 


SEND  FORM  FEED 

WRITE (15,’ (Al)’ >  FMFEED 

DO-  £10  1  =  1,22 

READ ( AUN I T, ’ ( AB0 > ’ , END=220 )  DLINE 
WRITE ( 15, ’ (AB0)’ )  DLINE 
CONTINUE 
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RETURN 

END 

CHARACTER*7  FUNCTION  EFILE(I) 

C****************************************************************************** 
C  THIS  FUNCTION  FORMS  THE  FILE  NAME  ARCHX,  WHERE  X  IS  DETERMINED  BY  THE 

C  VALUE  OF  I  PASSED  TO  THE  FUNCTION. 

C  VARIABLES  PASSED: 

C 

C  I  -  VALUE  TO  BE  CONCATENATED  ON  ARCH 

C 

C  VARIABLES  RETURNED: 

C 

C  EFILE  -  CHARACTER  NAME  ARCHX,  X  PASSED  THROUGH  THE  WINDOW 

C****************************************************************************** 

CHARACTERS  TEMP 

INTEGER  I 

C  BUILD  THE  FILE  NAME  ARCHX,  X=0,  1 , 2, . . . , 93 

EFILE (1:7)=’ ARCH  ’ 

WRITE (TEMP (1:2) , »  (12) M  I 
IF  (TEMP (1:1)  .EQ.  1  ’)  THEN 

EFILE (5:5) =TEMP (2:2) 

ELSE 

EFILE (5:6) =TEMP (1:2) 

END  IF 

RETURN 

END 

SUBROUTINE  PACK(STR, J) 

C*******»********************************************************************** 
C  THIS  SUBROUTINE  REMOVES  THE  BLANKS  FROM  WITHIN  A  CHARACTER  STRING 

C  AND  PADS  THE  STRING  WITH  BLANKS 

C 

C  VARIABLES  PASSED 

C  STR  -  CHARACTER  STRING  TO  BE  PACKED 

C 

C  VARIABLES  RETURNED 

C  J  THE  NUMBER  OF  NON-BLANK  CHARACTERS  IN  THE  RETURNED  STRING 

C***************^********** **************************************************** 

CHARACTER* ( * )  STR 

INTEGER  I,J 

L=LEN (STR) 

J=0 


C  REMOVE  THE  BLANKS  FROM  THE  CHARACTER  STRING 
DO  5  1=1, L, l 

IF  (STR (1:1)  .NE.  *  >)  THEN 

J=J+1 

STR  <  J : J ) =STR (1:1) 
END  IF 

5  CONTINUE 

C  PAD  THE  REST  OF  THE  STRING  WITH  BLANKS 


STR (1:1)=’  ’ 

10  CONTINUE 

RETURN 

END 

SUBROUTINE  REVENT ( ITR,  AUNIT,  SMUNIT, SMFILE, BUNIT, BFILE) 

C************************************************************************* 

C  REVENT  RECALLS  THE  EVENT  ARCHIVE  FILES.  A  LIST  IS  DISPLAYED  ON  THE 

C  SCREEN  ALLOWING  THE  USER  TO  SELECT  THE  DESIRED  ARCHIVE  FILE.  REVENT 

C  ASSUMES  THAT  A  DIRECTORY  LISTING  OF  AVAILABLE  ARCHIVE  FILES  HAS 

C  BEEN  CREATED  BY  THE  HOST  COMPUTER  SYSTEM  PRIOR  TO  RTMS  EXECUTION. 

C  THE  DIRECTORY  LISTING  FILE  MUST  BE  NAMED  * ARFILES’  AND  BE  IN  THE 

C  DIRECTORY  INDICATED  BY  ARGUMENT  BFILE. 

C 

C  VARIABLES  PASSED 

C 

C  ITR  -  INTERACTIVE  TERMINAL  READ  UNIT 

C  AUNIT  -  UNIT  FOR  RECALLED  ARCHIVE  FILE 

C  SMFILE  -  MENU  FILE  NAME 

C  SMUNIT  -  UNIT  FOR  SMFILE 

C  BFILE  -  CRQMIX  DIRECTORY  CONTAINING  ’ARFILES’ 

C  BUNIT  -  UNIT  FOR  ’ARFILES’ 

C************************************************************************** 
CHARACTER*Q0  OUT ( 19) , TLINE 

CHARACTER*47  FNAME < 1 ) ,  FNAME1 < 1 ) ,  TEMP, TEMPI 
CHARACTER*^®  BFILE 

CHARACTER*?  AFILE,  EFILE,  TFILE, SMFILE 

CHARACTER*3  INP(l) 

LOGICAL  FLAG 1, FLAGS, FLAG3 

INTEGER  ITR,  AUNIT,  JJ,  CNT, TUNIT, SMUNIT, RC (20, 3) , 

*  ST (3), BUNIT 

DATA  ST/0,0,0/ 

C  FORM  THE  LISTING  FILE  NAME,  PACK  IT  AND  SEE  IF  IT  EXISTS 
FNAME1 (1) ( 1 :47) =BFILE 
FNAME 1 ( 1 ) (41:47)=’ ARFILES’ 

TEMPI =FNAME1 ( 1 ) 

CALL  PACK (TEMPI, J) 

INQUIRE  (FILE=TEMP1,EXIST=FLAG1> 

IF  (.NOT.  FLAG I)  RETURN 

C  DISPLAY  THE  MAIN  MENU 

100  CALL  MENUSV (SMFILE,  115,  RC, 20,  SMUNIT) 

C  FLAG1  -  INDICATES  WHETHER  THE  SCREEN  IS  CLEAR 

C  FLAG2  -  INDICATES  WHETHER  ANY  FILES  EXIST 

FLAG1=. TRUE. 

FLAG2=. TRUE. 

15  CNT=2 

C  OPEN  THE  LISTING  FILE 

OPEN  (BUNIT, FILE-TEMPI, STATUS-’ OLD’ > 


C 


LOOK  FOR  ARCH  FILES  IN  THE  MASTER  FILE 


n  n 


£0  READ(BUNIT, ’ (080)* ,END=21>  TLINE 

IF  (TLINE < 18:21 )  . NE.  ’arch’)  GOTO  20 

C  FORM  THE  ARCHIVE  FILE  NAME  INCLUDING  THE  DIRECTORY  PREFIX 

AFILE=TLINE( 18:23) 

FNAME(l) (1 :47)=BFILE 
FNAME(l) (41 :47)=AFILE 
TEMP=FNAME ( 1 ) 

CALL  PACK (TEMP, J) 

FLAG£=. FALSE. 

FLAG 1=. FALSE. 

C  STORE  OFF  THE  FILE  NUMBER  XX  I.E.  ARCHXX 
OUT (CNT) (1:80)=’  ’ 

OUT (CNT) (1 :3>=AFILE(5:6) 

C  INPUT  THE  HEADER  LINE  OF  THE  ARCHIVE  FILE 
OPEN  (AUNIT, FILE=TEMP,  STATUS=»  OLD’ ) 

READ (AUNIT, *  (A80) ’ )  TLINE 
CLOSE  (AUNIT) 

C  STORE  OFF  THE  HEADER  INFORMATION  TO  DISPLAY  ALONG  WITH  THE  FILE  NO. 
OUT (CNT) (6:80>=TLINE 

C  CAN  ONLY  SHOW  19  ARCHIVE  FILE  NAMES  AT  ONCE  ON  THE  SCREEN 

IF  (CNT  .EQ.  19)  THEN 

C  OUTPUT  THE  19  FILE  NAMES 

CALL  MENUWR(RC,  20,  2,  19, OUT, 0, 2, ST) 

C  INPUT  THE  USERS  SELECTION 

45  INP ( 1 ) =’  ’ 

CALL  MENURD(RC, £0, 1, 1, INP, ITR) 

C  USER  SELECTED  TO  RETURN,  SO  CLOSE  THE  LISTING  FILE 

IF  ( INP ( 1 )  .EQ.  ’X  ’ )  THEN 

CLOSE  (BUNIT) 

RETURN 

ENDIF 


C  USER  SELECTED  TO  CONTINUE  LOOKING  AT  THE  LIST 

IF  ( INP ( 1 )  . EQ.  ’C  ’)  THEN 
FLAG1=. TRUE. 

CALL  MENUSV (SMF ILE,  1 15,  RC, £0, SMUNIT) 

CNT =£ 

GOTO  £0 

ENDIF 

USER  SELECTED  A  NUMBER  MAYBE,  CHECK  TO  BE  SURE  AND  ALSO  CHECK 
THAT  THE  ARCHIVE  FILE  THE  USER  PICKED  CAN  BE  OPENED 
READ ( INP, ’ (BN, 13) ’ , ERR=35)  JJ 

C  FORM  THE  FILE  INCLUDING  THE  DIRECTORY 

AFILE=EFILE ( JJ) 

FNAME(l) (1 :47) =BFILE 
FNAME(l) (41 : 47) =AFILE 
TEMP=FNAME ( 1 ) 

CALL  PACK (TEMP, J) 

INQUIRE  (FILE=TEMP, EXIST=FLAG3) 

IF  (.NOT.  FLAG3)  GOTO  45 
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onon  nnnnnnnnnnnnnonnn 


GOTO  1 
END 

SUBROUT  I NE  EVENT A  < AFLAG,  AUN I T ,  AF I LE, BF I LE ) 

C*************************************************************************** 
THIS  SUBROUTINE  OPENS  ON  EVENT  ARCHIVE  FILE  AND  WRITES  AN  80-BYTE 
HEADER  TO  IDENTIFY  THE  FILE. 

HEADER  FORMAT:  ARCHIVE  FILE:  ARCHXX  HH:MM:SS  MM/DD/YY 
VARIABLES  PASSED 

AUNIT  -  UNIT  FOR  OPEN  ARCHIVE  FILE 

AFILE  -  ARCHIVE  FILE  NAME,  E.G.,  ARCH0,  ARCH1,  . . . . ARCH99 
BFILE  -  CROMIX  DIRECTORY  CONTAINING  ARCHIVE  FILES  AND  FILE  LIST 

VARAIBLES  RETURNED 


AFLAG  -  FALSE:  COULD  NOT  OPEN  AFILE  (99  FILES  ARLREADY  EXIST) 
TRUE  :  FILE  WAS  OPEN  SUCCESSFULLY 

************************************************************************** 


CHA  R ACTE  R*  80  ASTAMP ( 1 > 

CHARACTER*40  BFILE 
CHARACTER*47  FNAME 
CHARACTER* 15  STAMP 
CHARACTER*?  AFILE, EFILE 

LOGICAL  AFLAG, FLAG 

INTEGER  AUNIT 

ASTAMP (1) (1:13)=  ’ARCHIVE  FILE:’ 

ASTAMP(l) (14:80)=’  ’ 

SEE  IF  AN  ARCHIVE  FILE  CAN  BE  OPENED.  IF  SO  OPEN  IT  AS 
ARCHX,  X=0,  1,2, . .  .  ,99 

ADD  A  54-CHARACTER  HEADER  IN  THE  FILE  WHICH  GIVES  THE  FILE  NAME 
AND  TIME  -  DATE  OF  CREATION. 

DO  10  1*0,99,1 
AFILE=EFILE ( I ) 

FNAME (1:47)=BFILE 
FNAME (41 :47)=AFILE 
CALL  PACK (FNAME,  J) 

INQUIRE  (FILE=FNAME,  EX IST=FLAG) 

IF  (.NOT.  FLAG)  THEN 

AFLAG*. TRUE. 

OPEN  (AUNIT, FI LE-FNAME, STATUS*’ NEW’ ) 
ASTAMP(l) (14:20)=AFILE 
CALL  DATE (STAMP) 

ASTAMP ( 1 ) ( 23 : 37 ) =ST AMP 
CALL  TIME (STAMP) 

ASTAMP ( 1 )  <  40 : 54 ) =STAMP 
WRITE (AUNIT, ’ (A80)’ >  ASTAMP(l) 

RETURN 
END  IF 

10  CONTINUE 


AFLAG*. FALSE 


n  n 


READ  IN  ALL  THE  SYSTEM  PARAMETERS  FROM  SYSPARM  THAT  THE  PROGRAM 
WILL  NEED  TO  EXECUTE. 

OPEN  (£0,  FILE=’  SYSPARM’  ,  STATUS=’  OLD’  ) 

READ (£0,  *)  ITR,  AUNIT,  AUNIT1,  HUNIT,  SUNIT1, SUN ITS, SUNIT3, SUNIT4, 

*  CUNIT, CFILE, SFILE1 , SFILE2, SFILE3, SFILE4, HFILE,  SHFILE, 

*  PUNIT1,  PUNIT2,  PFILE1 , PHFILE, SMUNIT, SMFILE, BUNIT, BFILE, 

*  MUNIT, MFILE 
CLOSE  (£0) 

C  SET  UP  DEFAULTS 
AFLAG=. FALSE. 

MREAD=. TRUE. 


DISPLAY  THE  MAIN  MENU 
CALL  ONOFF ( 0 ) 

CALL  MENUSV (SMFILE,  100, RC, 2,  SMUNIT) 
CMD ( 1 ) =’  ’ 

CALL  MENURD(RC, 2, 1, 1, CMD, ITR) 


CHECK  FOR  A  VALID  INPUT 

IF  ( INDEX (’ 12345SX’ , CMD (1) )  . EQ.  0)  THEN 

CALL  MESS  < 1 1 , RC (2, 1 ) , RC (2, 2) , RC (2, 3) , £) 
GOTO  2 

END  IF 

IF  (CMD ( 1 )  .EQ.  ’1’)  THEN 

IF  (AFLAG)  THEN 

CALL  MESS  < 12, RC (2,  1 ) , RC (2, 2) , RC (2, 3) , 6) 

ELSE 

CALL  EVENTA (AFLAG, AUNIT, AFILE, BFILE) 

IF  (AFLAG)  THEN 

CALL  MESS (13, RC (2, 1 ) , RC (2, 2> , RC (2, 3) ,  £) 

ELSE 

CALL  MESS ( 14, RC (2, 1 ) , RC (2, 2) , RC (2, 3) , 6) 

END  IF 
END  IF 

GOTO  2 
END  IF 

IF  (CMD ( 1 )  .EQ.  ’2’)  CALL  REVENT ( ITR, AUNIT1 , SMUNIT, SMFILE, 

*  BUNIT, BFILE) 

IF  (CMD ( 1 )  .EQ.  ’3’)  CALL  TCCM ( ITR, AUNIT, AFLAG, SUNIT1, SUNIT2, 

*  SUNIT3,  SUNIT4, CUNIT, CFILE, SFILE1, 

*  SFILE2, SFILE3, SFILE4, SMUNIT, SMFILE, 

*  MUNIT, MFILE) 

IF  (CMD  < 1 )  .EQ.  ’4’)  CALL  DBMM ( ITR, CUNIT, SUNIT1, SUNIT2, SUNIT3, 

*  SUNIT4, CFILE, SFILE1 , SFILE2, SFILE3, 

*  SFILE4, SHFILE, PUNIT1, PUNIT2, PFILE1, 

*  PHFILE, SMUNIT, SMFILE) 

IF  ( CMD  ( 1 )  .EQ.  ’5’)  THEN 

CALL  TIME (STAMP) 

CALL  MENUDR (STAMP, RC (2, 1 > , RC (2, 2) , 7, 0, 1 , 1 ) 
GOTO  2 
END  IF 

IF  (CMD ( 1 >  .EQ.  ’6’)  CALL  HELP (ITR, HUNIT, HFILE, SMUNIT, SMFILE) 

IF  (CMD  ( 1 )  .EQ.  ’X’)  THEN 

IF  (AFLAG)  CLOSE  (AUNIT) 

CALL  CLEAR (7,0) 

CALL  ONOFF  < 1 ) 

STOP 
END  IF 
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CHARACTER* (*)  STR 
INTEGER  N, I 

C  SEARCH  THE  STRING  BACKWARDS  FOR  A  NON  BLANK  CHARACTER 
DO  5  I=N, £, -1 

IF  (STR (1:1)  .NE.  ’  »)  GOTO  10 
5  CONTINUE 

C  RETURN  THE  NON  BLANK  POSITION 

10  BNDX=I 

RETURN 
END 

SUBROUTINE  HELP ( ITR,  HUNIT,  HFILE,  SMUNIT, SMFILE) 

C**** ******************************* ******************************************** 

C  THIS  SUBROUTINE  DISPLAYS  THE  HELP  FILE.  THE  OPTION  OF  THE  HELP  FILE  TO 

C  BE  DISPLAYED  IS  DETERMINED  BY  THE  USER  INPUT.  THE  HELP  FILES  ARE  SPLIT 

C  UP  BY  SPECIAL  DELIMITERS.  THEY  ARE  *#**»,  WHERE  #  IDENTIFIES  THE  PART 

C  OF  THE  FILE  THE  USER  WANTS  TO  SEE  AND  &&  IS  THE  LENGTH  OF  THE  TEXT  THAT 

C  PRETAINS  TO  THAT  PORTION  OF  THE  FILE. 

C  VARIABLES  PASSED] 

C 

C  ITR  -  INTERACTIVE  TERMINAL  READ  UNIT 

C  HUNIT  -  UNIT  *  TO  OPEN  TH£  HELP  FILE  (HFILE)  ON 

C  HFILE  -  SYSTEM  LEVEL  HELP  FILE  NAME 

C  SMUNIT  -  UNIT  »  TO  OPEN  THE  MENU  FILE  (SMFILE)  ON 

C  SMFILE  -  MENU  FILE  NAME 

C****************************************************************************** 

CHARACTER*80  TLINE, LINE 
CHARACTER*?  HFILE, SMFILE 
CHARACTER*!  CMD(l) 


INTEGER  ITR,  HUNIT,  SMUNIT,  RC(3,  3) 

LOGICAL  FLAG 

C  DISPLAY  THE  MAIN  MENU,  AND  GET  THE  USER  INPUT 
1  CALL  MENUSV (SMFILE,  1£5,  RC,  3,  SMUNIT) 

£  CMD ( 1  >  ='  * 

CALL  MENURD(RC, 3, 1, 1,CMD, ITR) 


C  CHECK  FOR  A  VALID  INPUT 

IF  ( INDEX (’ 12345X’  ,  CMD(l) )  .  EQ.  0)  THEN  1 

CALL  MESS (11, RC(2, 1), RC (£,£), RC(£,3),  6) 
GOTO  £ 

END  IF 

C  THE  USER  SELECTED  TO  RETURN 
IF  (CMD ( 1  >  .EQ.  *X’>  RETURN 


C 

C 


CHECK  TO  SEE  THAT  THE  HELP  FILE  PASSED  EXITS,  IF  NOT  DISPLAY  AN  ERROR 
MESSAGE  THAT  HELP  IS  NOT  AVAILABLE  AND  GO  AND  GET  THE  USERS  INPUT 
INQUIRE  (FILE*HFILE,EXIST*FLAG) 

IF  (.NOT.  FLAG)  THEN 

CALL  MESS (15,  RC(£,  1 ) ,  RC (£,  2) , RC (£, 3) , 6) 

GOTO  2 
END  IF 


***********  *«  **  •«»***••***  »$*(***«****  »»***»***»**»  •»  tt 
itwttwttm  **  **  tttttttttttt*  •*••«•«*•••*  *»•••••*•••»*  *»*  «•» 
**  •*  •*  ••  •*  •*  ••  «•  MM  •••* 


****•*«»*•**«  **•«•***»*  •••••••»•••  ••  ••  •••••••••• 

•*•••*•••••**  *•  ••  «•  «*  ••  M 


PROGRAM  MAPDIG 


C  THIS  PROGRAM  ALLOWS  THE  USER  TO  EXTERNALLY  DIGITIZE  MAPS 

CHARACTER* 1  CMD(l) 

CHARACTER*?  SMFILE,  MHFILE, MFILE 

INTEGER  ITR, SMUNIT, RC  <2,  3) , MUNIT, MUNIT1, MUNIT2, MUNIT3, 

*  ITD 

C******************** 

SMFILE=*  SYSMENU’ 

MHFILE=’  MHELP  ’ 

MFILE=’ MAP.  DB  » 

MUNIT=43 

MUNIT 1=40 

MUNIT2=41 

MUNIT3=42 

SMUNIT=44 

ITR=0 

ITD=0 

CALL  ONOFF (0) 

C******************** 

1  CALL  MENUSV (SMFILE, 130, RC, 2,  SMUNIT) 

2  CMD ( 1 ) =  ’  ’ 

CALL  MENURD (RC,  2,  1, 1, CMD, ITR) 

IF  (INDEX (’ 13X’  ,CMD(1) )  .  EQ.  0)  THEN 

CALL  MESS (11, RC(2, 1 > , RC (2, 2) , RC (£, 3) , 6) 
GOTO  2 

ENDIF 

IF  (CMD ( 1 )  .EQ.  ’l’>  CALL  MHELP (ITR, MUNIT, MHFILE, SMUNIT, SMFILE) 
IF  (CMD ( 1 )  .EQ.  ’3’)  CALL  MADD( ITR, MUNIT1 , MUNIT2, MUNIT3, MFILE, 

*  SMUNIT, SMFILE, ITD) 

IF  (CMD ( 1 )  .EQ.  ’X’)  THEN 

CALL  CLEAR (7,0) 

CALL  ONOFF ( 1 ) 

STOP 

ENDIF 

GOTO  1 
END 

SUBROUT I NE  MHELP (ITR,  MUN I T ,  MHF I LE, SMUN I T, SMF I LE ) 

CHARACTER*80  TLINE, LINE 
CHARACTER*?  MHFILE, SMFILE 
CHARACTER*!  CMD(l) 


INTEGER 

LOGICAL 


ITR, MUNIT, SMUNIT,  RC (3,  3) 
FLAG 


1  CALL  MENUSV (SMFILE,  135,  RC,  3,  SMUNIT) 

2  CMD ( 1 ) =’  ’ 

CALL  MENURD (RC, 3, 1,  1,CMD,  ITR) 

C  CHECK  FOR  A  VALID  INPUT 

IF  (INDEX <’2X’,CMD(1))  .  EQ.  0)  THEN 


=  -  1 

COLL  MESS ( 1 1, RC (£, 1 ) , RC <2, 2) , RC<£, 3) , 7) 

GOTO  2 

ENDIF 

IF  (CMD(l)  . EQ.  ’X’>  RETURN 
INQUIRE  <FILE=MHFILE,  EXIST=FLAG) 

IF  (.NOT.  FLOG)  THEN 

CALL  MESS (15,  RC (2,  1 ) , RC (2, 2) , RC  (2,  3) ,  6)  j 

GOTO  2  ] 

ENDIF  j 

COLL  CLEAR (7, 0)  ! 

OPEN  (MUNIT, FILE=MHFILE,  STATUS^’  OLD’  ) 

TLINE ( 1 : 80) =’ *X*’ 

TL I NE ( 2 : 2 ) =CMD ( 1 ) 

READ (MUNIT, ’ (A80> ’ >  LINE 
IF  (TLINE (1:3)  . EQ.  LINE(1:3>)  THEN 
READ (LINE (4:5),’ (12)’ )  IG 
J=0 

DO  20  1=1, IG, 1 

READ (MUNIT, ’ (A80) ’ >  LINE 
J=J+1 

CALL  MENUDR(LINE, J, 1,2,0, 1, 1) 

IF  (MOD (I, 22)  .EQ.  0)  THEN 
IF  (I  .EQ.  IG)  THEN 

CALL  MESS (19,  RC(3,  1 ) ,  RC (3, 2) , RC (3, 3) , 7) 

READ ( ITR, ’ (Al) ’ )  CMD ( 1 ) 

CLOSE  (MUNIT) 

GOTO  1 

ELSE 

CALL  MESS <16, RC(3, 1) , RC(3,2> ,  RC(3,  3) ,  7) 

READ (ITR, ’ (Al)’ >  CMD(l) 

CALL  CLEAR (7,0) 

J=0 

ENDIF 

ENDIF 

CONTINUE 

CALL  MESS  (19,  RC  (3,  1 ) ,  RC  (3,  2) ,  RC  (3,  3) ,  7) 

READ (ITR, ’ (Al)’ >  CMD ( 1 ) 

CLOSE  (MUNIT) 

GOTO  1 

ENDIF 


GOTO  5 
END 

SUBROUTINE  MADD  <  ITR, MUNIT1 , MUNIT2, MUNIT3, MFILE, SMUNIT, SMFILE,  ITD) 


CHARACTER*48 

CHARACTER*40 

CHARACTER*7 

CHARACTER*! 


B48 

FNAME (3) , MNAME, MNAME1 , MNAME2, MNAME3, MNAMEX, B40 
SMFILE, MFILE 
CMD ( 1 ) , INP 


INTEGER  RC (5,  3) ,  SMUNIT,  MUNIT1 ,  MUNIT2,  ITR,  ST (3) , HDR, MUNIT3, 

*  HDR1, HDR2, ITD 


LOGICAL  FLAG, FLAG 1,FLAG£ 


DATA  ST/0,0,0/ 


FNAME (1) (ls40)=’  ’ 
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FNAME (£) (1:40)=’  ’ 

FNAME (3) (1:40)=’  ’ 

IMP**  i 

ITT=-1 

CALL  MENUSV (SMFILE,  199,  RC,  5,  SMUNIT) 

ST (3) *0 

CALL  MENUWR  <  RC,  5,  1,3,  FNAME,  0,  1,ST) 

FLAG  TO  GQ  TO  COMMAND  LINE  AFTER  FIRST  TIME 
IF  (INP  .EQ.  ’ 4’  )  GOTO  10 

IST=1 

CALL  MENURD (RC,  5,  1ST,  3,  FNAME,  ITR) 

CMD ( 1 )  =’  ’ 

CALL  MENURD (RC, 5, 4, 4, CMD, ITT) 

IF  (CMD ( 1 )  .EQ.  ’  ’>  THEN 

ST (3) =1 

CALL  MENUWR  ( RC,  5,4,4,  CMD,  0,1,  ST) 

CALL  MESS (4, RC(5, 1  > ,  RC  (5,  £) ,  RC  (5,  3) , 1) 

IST*1 
GOTO  15 
END  IF 

IF  (CMD ( 1 )  .EQ.  ’XM  RETURN 
IF  (CMD ( 1 )  .NE.  ’CM  GOTO  10 

CHECK  THAT  NONE  OF  THE  FILE  NAMES  ARE  BLANK 
DO  20  K=l, 3, 1 

IF  (FNAME (K)  . EQ.  ’  ’)  THEN 

ST (3) =1 
CMD  ( 1 )  =*  ’ 

CALL  MENUWR (RC, 5, 4, 4, CMD, 0,1, ST) 

CALL  MESS ( 1,  RC (5,  1 ) , RC (5, £> , RC (5, 3) , 7) 

IST-K 

GOTO  15 

END  IF 


CONTINUE 


CHECK  THAT  THE  SYMBOL  FILE  EXISTS 
MNAME3=FNAME(3> 

CALL  PACK (MNAME3, J) 

INQUIRE  ( F I LE*MNAME3 ,  E X I ST “FLAG ) 

IF  (.NOT.  FLAG)  THEN 

ST (3) =1 
CMD ( 1 ) =’  ’ 

.  CALL  MENUWR (RC, 5, 4, 4, CMD, 0,  1, ST) 

CALL  MESS (18,  RC(5, 1 ) ,  RC (5, 2) , RC (5, 3), 7) 

IST=3 
GOTO  *5 
END  IF 

SET  UP  THE  MAP. DB  DSI&  BASE  IF  NECESSARY 
INQUIRE  (FILE«MFILE,EXIST«FLAG> 

IF  (.NOT.  FLAG)  THEN 

OPEN  (MUNIT3, FILE=MFILE,  STATUS*’  NEW’  , ACCESS*’  DIRECT* , RECL*42, 
*  FORM*’ FORMATTED’  ) 

HDR*1 

B40  ( 1 1 40) »'  ’ 

WRITE (B40 ( 1 s 4) , ’  (14)’ )  HDR 
WRITE (MUNIT3, ’ (A40> ’ , REC-1 )  B40 
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WRITE (MUNIT3, ’ (A40) ’ , REC=2)  B40 
CLOSE  (MUNIT3) 

END  IF 

SET  UP  THE  BASE  MAP  DATA  BASE  IF  NECESSARY 
FLAG1=. FALSE. 

MNAME 1 =FNAME  1 1 ) 

CALL  PACK < MNAME 1, J) 

INQUIRE  <FILE=MNAME1,  EXIST=FLAG) 

IF  (.NOT.  FLAG)  THEN 

OPEN  ( MUN I T 1 , F I LE=MNAME 1 ,  STATUS®’ NEW’  , ACCESS®’ D I RECT’ , 

*  FORM®’  FORMATTED’ ,  RECL=50) 

HDR=1 

848(1:48)=’  ’ 

WRITE (B48 (1:4),’ (14)’)  HDR 
WRITE(MUNIT1,  ’  (A48) ’ , REC=1)  B48 
WRITE (MUNIT1 , ’ (A48) ’ , REC=£)  B48 
CLOSE  (MUNITl) 

FLAG1=. TRUE. 

ENDIF 

MNAME2=MN AME 1 

IF  <(J+1>  .GT.  38)  THEN 

MNAME2 (38:40)=' . MM’ 

ELSE 

MNAME2 ( J+l : J+3) =’  .  MM’ 

ENDIF 

SET  UP  THE  MAP  DATA  BASE  IF  NECESSARY 
FLAG2=. FALSE. 

INQUIRE  (FILE=MNAME2, EXIST=FLAG) 

IF  (.NOT.  FLAG)  THEN 

OPEN  (MUNIT2,  FILE=MNAME2,  STATUS=’  NEW’ , ACCESS*’ DIRECT’ , RECL=42, 

*  FORM*’ FORMATTED’  ) 

HDR=1 

B40 ( 1 : 40) =’  ’ 

WRITE (B40 (1:4),' (14)’)  HDR 
WRITE (MUNIT2, ’ (A40) * , REC=1 )  B40 
WRITE (MUNIT2, ’ (A40) ’, REC=2)  B40 
CLOSE  (MUNIT2) 

FLAG2=. TRUE. 

ENDIF 

ADD  THE  BASE  MAP  NAME  TO  MAP. DB 

OPEN  (MUNIT3, FILE=MFILE, STATUS=’  OLD’ , ACCESS®’ DIRECT’ , 

*  FORM®’ FORMATTED’ , RECL=42) 

READ (MUNIT3, ’ (A40) ’ , REC=1 )  B40 
READ (B40 (1:4), ’(14)’ )  HDR 

DO  25  K=2, HDR, 1 

READ (MUNIT3, ’ (A40) ’ , REC=K)  MNAME 
CALL  PACK (MNAME, J) 

IF  (MNAME  .EQ.  MNAME 1)  GOTO  30 
CONTINUE 
HDR=HDR+1 

WRITE (MUNIT3, ’ (A40)’ , REC=HDR)  FNAME(l) 

1 I I=HDR+1 

WRITE (MUNIT3, ’  (A40) ’ , REC=I 1 1 )  FNAME(l) 

OPEN  THE  BASE  MAP  DAXA  BA$E  AND  THE  MAP  DATA  BASE 

OPEN  (MUNITl, FILE*MNAME1,  STATUS*’ OLD’ ,  ACCESS®’ DIRECT’ , 

*  FORM®’ FORMATTED' ,  RECL®50> 


OPEN  (MUNIT£, FILE=MNAME£,  STATUS*’  OLD* , ACCESS*’  DIRECT’  , 

*  FORM*’ FORMATTED’ , RECL=4£) 

MNAMEX=FNAME (£> 

CALL  PACK (MNAMEX, J) 

CHECK  THAT  THE  MAP  FILE  NOT  ALREADY  THERE 
READ (MUNIT1 , *  (A48) ’ , REC=1 )  B48 
READ (B48 (1:4),’ (14) ’ )  HDR1 
DO  35  K*2,HDR1,  1 

READ ( MUN I T 1 , ’ ( A40 ) ’ , REC=K)  MNAME 
CALL  PACK (MNAME, J) 

IF  (MNAME  .EQ.  MNAMEX  >  THEN 
ST (3) =1 
CMD ( 1 )  =’  ’ 

CALL  MENUWR  ( RC,  5,  4,  4,  CMD,  0,  1 ,  ST) 

CALL  MESS  (£,  RC  (5,  1 ) ,  RC  (5,  £) ,  RC  <5,  3) ,  7) 

IST=£ 

GOTO  15 

END  IF 

CONTINUE 

HDR1=HDR1+1 

READ (MUNIT£, ’ (A40) ’ , REC=1 )  B40 
READ (B40 (1:4),’ (14) ’ )  HDR£ 

HDR2*HDR£+1 

IS=HDR£ 

CALL  MDIG ( ITR, SMUNIT, SMFILE,  MUNIT£, HDR£, IERR, ITD, FNAME ( ?) , 

*  FNAME (3)) 

IF  (IERR  .EQ.  0)  THEN 

IE=HDR£ 

B48  (1 :48)  *'  ’ 

WRITE (B4Q (1:4),’ (14)’)  HDR1 
WRITE (MUNIT1, ’ (A48) ’ , REC*1 )  B48 
B4S(1:4S)*’  ’ 

B48 (1:40) =FNAME ( £ ) 

WRITE (B48 (41:48),’  (£14)')  IS,  IE 
WRITE (MUNIT1, ’  (A48)  ’  , REC=HDR1 )  B48 
I I I=HDR1+1 

WRITE (MUNIT1, ’  ( A48) ' , REC=I 1 1 )  B48 
B40 ( 1 : 40) =’  ’ 

WRITE (B40(ls4),’ (14)’ )  HDR£ 

WRITE (MUNIT£, ’ (A40>* , REC*1)  B40 
WRITE (MUNIT£, ’ (A40) * , REC=IE+1)  B40 
B40 ( 1 j  40) =’  ’ 

WRITE (B40 (1:4),' (14)*)  HDR 
WRITE (MUNIT3, ’ (A40)’ , REC=1)  B40 
EUDIF 

IF  ((IERR  .NE.  0). AND. (FLAG1) )  THEN 

CLOSE  ( MUN I Tl, STATUS*’  DELETE’  > 
ELSE 

CLOSE  (MUNIT1 ) 

END  IF 

IF  ((IERR  .NE.  0). AND. (FLAGS) )  THEN 

CLOSE  (MUNIT£, STATUS*’ DELETE’ > 
ELSE 

CLOSE  (MUN ITS) 

ENDIF 

CLOSE  (MUNIT3) 

INP-’ »’ 

40 


GOTO  5 


5 


10 


END 

SUBROUTINE  PACK ( STR, J> 

CHARACTER*  (*)  STR 

INTEGER  I,J 

L=LEN (STR) 

J=0 


DO  5  1  =  1, L,  1 

IF  (STR ( 1:1)  .NE. 


CONTINUE 


’ )  THEN 
J=J+1 

STR  < J: J>  =STR (1:1) 
END  IF 


DO  10  I=J+1,L, 
STR (1:1)=’ 
CONTINUE 


1 

i 


RETURN 

END 

SUBROUTINE  MDIG ( ITR,  SMUNIT,  SMFILE,  MUNITE, HDRE, IERR, ITD, 
*  MFILE, SFILE) 


CHARACT£R*40 

CHARACTER*30 

CHARACTER*E0 

CHARACTER* 15 

CHARACTER* 10 

CHARACTER*? 

CHARACTER*6 

CHARACTER*£ 

CHARACTER*! 


TEXT (4) , SFILE, MFILE, TSTAMP, TFILE 
MES  < 1 ) 

IOP, ANNO(l) 

TEMP 
DIG (E) 

SMFILE 
USRUNT ( 1 ) 

INP(l) 

CMD ( 1 ) 


INTEGER  ITR, SMUNIT, MUNITE, HDRE, IERR, ITD, RC ( 10, 3) , ST (3) , 

*  ANGLE ( 40 ) , WCS ( 40, 3 ) , L I NK ( 8 ) 

REAL  VLX, VLY, VUX, VUY,  ULX, ULY,  UUX, UUY, SCALE (40) 

DATA  ST/0,0,0/ 


ITT=-1 

USRUNT ( 1 ) =’ FEET  ’ 

C  INI  TALI ZE  THE  MENU  VARIABLES 

100  TEXT<1) (1:40)=’  ’ 

TEXT(E)  (1:40)--  » 

TEXT (3> ( 1 :40) =  *  ’ 

TEXT (4) ( 1 :40) =*  ’ 

C  DISPLAY  THE  DIGITIZING  MENU 

CALL  MENUSV (SMFILE, £00, RC, 10, SMUNIT) 

C  DISPLAY  THE  USER  UNITS 

ST (3) =1 

CALL  MENUWR (RC, 10, 3, 3, USRUNT, 0, 1,ST) 
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C  READ  IN  THE  TITLE 

CALL  MENURD (RC, 10, 1,2, TEXT, ITR) 

C  INPUT  THE  USER  UNITS 

DIG ( 1 ) ( 1 i 10) =’  ’ 

DIG(£) (1:10)='  ’ 

IST=4 

301  CALL  MENURD (RC, 10, 1ST, 5, DIG, ITT) 

READ(DIGd)  (1:10),’  (F10.  0) »  ,  ERR=30£>  ULX 
READ(DIG(£) (1:10), '  (F10.  0) '  , ERR=303)  ULY 
GOTO  400 

302  IST=4 
GOTO  301 

303  IST=5 
GOTO  301 

C  INPUT  THE  VIRTUAL  UNITS  FROM  THE  DIGITIZER 
400  MES(1)=’ DIGITIZE  LOWER  LEFT  POINT’ 

CALL  MENUWR(RC, 10, 8, Q, MES, 0, 7, ST) 

READ ( ITD, *)  I BUT, VLX, VLY 
MES(l) (1:30)=’  ’ 

CALL  MENUWR (RC, 10, 8, 8, MES, 0, 1, ST) 

C  INPUT  THE  USER  UNITS 
DIG(l) (1: 10)=’  ’ 

DIG(2) (1:10)=’  ’ 

IST=6 

310  CALL  MENURD (RC, 10, 1ST, 7, DIG, ITT) 

READ (DIG ( 1 ) (1:10),’ (F10. 0) ’ , ERR=31 1 )  UUX 
READ (DIG (2)  (1:10),*  (F10.  0) » , £RR=312>  UUY 
GOTO  500 

31 1  IST=6 
GOTO  310 

312  IST=7 
GOTO  310 

C  INPUT  THE  VIRTUAL  UNITS  FROM  THE  DIGITIZER 

500  MES(1)=’ DIGITIZE  UPPER  RIGHT  POINT’ 

CALL  MENUWR (RC, 10,  9,  9,  MES,  0,  7,  ST) 

READ (ITD,*)  IBUT, VUX, VUY 
MES(l) (1:30)=’  ’ 

CALL  MENUWR (RC, 10,  9,  9,  MES,  0,  1,ST> 

C  SCAN  THE  COMMAND  INPUT  LINE 

200  CMD ( 1 ) =’  ’ 

CALL  MENURD (RC,  10,  10,  10, CMD, ITT) 

IF  (CMD ( 1 )  .EQ.  ’X’)  THEN 

IERR=1 
RETURN 
END  IF 

IF  (CMD ( 1 )  .EQ.  ’R’)  GOTO  100 
IF  (CMD ( 1 )  .NE.  ’C’>  GOTO  £00 

C  FILL  IN  THE  HEADER  INFORMATION  OF  THE  FILE 
WRITE (MUNIT2, ’ (A40) ’ , REC-HDR2)  MFILE 

C  WRITE  THE  MAP  DESCRIPTION  IN  THE  HEADER 
WRITE (MUNIT2, * (A40)  ’ ,  REC-HDR2+1 )  TEXT(l) 
WRITE (MUNIT2,  ’  (A40) * , REC=HDR2+2>  TEXT (2) 


WRITE (MUNIT2, ’ (040) * , REC=HDR£+3)  TEXT<3) 

WRITE  <MUNIT2, ’  (A40) ’ , REC=HDR2+4>  TEXT<4) 

C  WRITE  THE  SYMBOL  FILE  NAME  IN  THE  HEADER 
WRITE (MUNIT2, 1 (A40) ’ , REC=HDRE+5)  SFILE 

C  OBTAIN  THE  TIME  STAMP  FOR  CREATION  DATE 
TSTAMPd  ; 40)=’  ’ 

CALL  TIME (TEMP) 

TSTAMP (1:10) =TEMP (1:10) 

CALL  DATE (TEMP) 

TSTAMPd  1 :20)=TEMP(1 : 10) 

C  WRITE  THE  TIME  AND  DATE  STAMP  IN  THE  HEADER 
WRITE (MUNIT2, » (A40) * , REC=HDR£+6>  TSTAMP 

C  STORE  THE  VIRTUAL  AND  USER  UNITS  IN  THE  HEADER 
WRITE (TEXT (4) (1:40),’ (4F10. 2) * )  VLX, VLY, ULX, ULY 
WRITE (MUNIT2, ’ (A40) ’ , REC=HDR£+7>  TEXT (4) 

C  STORE  THE  VIRTUAL  AND  USER  UNITS  IN  THE  HEADER 
WRITE (TEXT (4) (1:40), ’ (4F10.2)’ )  VUX, VUY, UUX, UUY 
WRITE (MUNIT2, ’ (A40) ’ , REC=HDR2+fl)  TEXT (4) 

C  OUTPUT  THE  USER  UNITS,  SUB  UNITS  ... 

TEXT (4 ) (1:40)=’  ’ 

TEXT (4) <1 :6)=USRUNT(1) 

TEXT (4) (7:12)=’ INCHES’ 

TEXT (4) (13:16)=’  12’ 

TEXT (4) (17:20)=’ 0000’ 

WRITE (MUNIT2, ’ (A40) ’ , REC=HDR2+9>  TEXT (4) 

C  BLANK  OUT  THE  UNUSED  HEADER  RECORDS 
TEXT (4) (1:40)=’  ’ 

WRITE (MUNIT2, ’ (A40) ’ , REC=HDR2+10)  TEXT(4) 

WRITE (MUNIT2, ’ (A40) ’ , REC=HDR£+1 1 )  TEXT (4) 

WRITE (MUNIT2, ’ (A40) ’ , REC-HDR2+12)  TEXT (4) 

WRITE (MUNIT2, ’ (A40) ’ , REC=HDR£+13)  TEXT (4) 

WRITE (MUNIT2, ’ (A40) ’ , REC=HDR£+14>  TEXT(4> 

C  POINT  TO  THE  LAST  RECORD 
HDR2=HDR2+ 1 4 

C  SET  UP  THE  DEFAULT  WEIGHT,  COLOR,  STYLE,  SCALE  AND  ANGLE 
DO  539  1  =  1, 40,  1 
WCS(I, 1)=0 
WCS ( I, 2) =1 
WCS ( I, 3) =0 
SCALE ( I ) = 1 . 

ANGLE ( I ) =0 
599  CONTINUE 

TFILE=SFILE 
CALL  PACK (TFILE, J) 

C  READ  IN  THE  SYMBOL  FILE  AND  SET  THE  WEIGHT,  STYLE,  ... 

OPEN  (SMUNIT,  FILE=TFILE,  STATUS*’  OLD’ , ACCESS*’ DIRECT’ , RECL=£0, 
*  FORM-’  FORMATTED’  ) 

READ(SMUNIT, *  <I£)’,REC=1)  I HD 
DO  598  1*1, I HD,  1 

READ (SMUNIT, '  (A£0> * , REC-I  +  l >  IOP 
READ<I0P<1 :£>, ’ (12) ’ )  II 
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READ  ( I OP ( 3 : 1 6  > ,  ’  <3I£,  F4.  2,  14)’  )  WCS (I I,  1 ) ,  WCS (11,2).  WCS (11,3), 

*  SCALE (II), ANGLE (II) 

598  CONTINUE 

CLOSE  (SMUNIT) 

C  DISPLAY  THE  ENTRY  MENU 

800  LINK ( 1 ) =0 
LINK (2) =0 
LINK (3) =0 
LINK (4) =0 
LINK (5) =0 
LINK (6) =0 
LINK (7) =0 
LINK (8) =0 

CALL  MENUSV (SMFILE,  210, RC,  10, SMUNIT) 

C  INPUT  THE  ANNOTATION 

ANNO(l) (1:20)*’  • 

CALL  MENURD ( RC, 10, 1, 1, ANNO, ITR) 

AX=0. 

AY=0. 

IF  (ANNO ( 1 )  .NE.  ’  ’)  THEN 

TEXT(1>=’ DIGITIZE  ANNOTATION  PLACEMENT’ 

ST  (3)  =1 

CALL  MENUWR ( RC,  10, 2,  2,  TEXT,  0,  7,  ST) 

READ ( ITD, *)  I BUT, AX, AY 

END  IF 

C  SCAN  THE  COMMAND  INPUT  LINE 
300  INP ( 1 ) ='  ’ 

CALL  MENURD (RC, 10, 3, 3, INP, ITT) 

IF  ( INP ( 1 )  .EQ.  ’X  ’ )  THEN 

IERR=0 
RETURN 
END  IF 

C  CHECK  FOR  A  VALID  INPUT 

READ ( INP ( 1 ) (1:2),’  ( 12)  ’ , ERR=300>  II 
IF  ((II  .LE.  0).OR.  (II  .GE.  21))  GOTO  300 

C  IF  POINT  FIND  OUT  IF  POTENTIAL  SOURCE 

IF  ((II  .EQ.  1>.0R.  (II  .EQ.  2).  OR.  (II  .  EQ.  3).  OR.  (II  .  EQ.  8) .  OR. 

*  (II  .EQ.  16). OR. (II  .EQ.  17))  THEN 
CMD  ( 1 )  =’  ’ 

CALL  MENURD (RC, 10, 4, 4,  CMD, ITT) 

LINK ( 1 ) =0 

IF  (CMD  ( 1 )  .EQ.  ’Y’>  LINK  ( 1 )  ®1 

END  IF 

C  ENTER  THE  MAP  DATA 

CALL  MAPDAT( ITR,  SMUNIT,  SMFILE,  MUNIT2,HDR2, ITD, 1 1 , WCS, SCALE, 

*  ANGLE, 40, ANNO ( 1 ) , AX, AY, LINK) 

GOTO  600 
END 

SUBROUTINE  MAPDAT ( ITR,  SMUNIT, SMFILE,  MUNIT, HDR, ITD, 1 1, WCS, SCALE, 

*  ANGLE,  N,  ANNO, AX, AY, LINK) 

CHARACTER*40  10 
CHARACTER*20  ANNO 
CHARACTER*?  SMFILE 
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INTEGER 


ITR, SMUNIT, MUNIT, HDR, ITD, 1 1 , ANGLE (N) , WCS (N, 3) , 
L I NK ( 8 ) 


LOGICAL 


VX, VY, VX1, VY1, SCALE  <N) , VXMIN, VYMIN, VXMAX, VYMAX, 
AX,  AY 

FLAG 


FLAG=. TRUE. 

ENTRY  WILL  BE  A  POINT 

IF  ((II  .  EQ.  l).OR.  (II  .EQ.  S>.OR.  (II  .  EQ 
*  (II  .EQ.  16). OR. (II  .EQ.  17))  THEN 
10(1:40)=’  ’ 

10(1:2)=’ 10’ 

WRITE (10(3:4), ’ (12) ’ )  II 
10(5:6)=’  1* 

WRITE (10 (7:20) , ’ (312, F4. 2, 14) ’ )  WCS ( I 


OR. (II 


10(21 :24)=’ 0000’ 

WRITE (10 (25:40) , ’ (812) ’ )  LINK 
WRITE (MUNIT, ’ (A40) ’ , REC=HDR+1 ) 


WCS (11,1), WCS (11,2), WCS (11,3), 
SCALE (II), ANGLE (II) 


WRITE (10(1 :20) , ’ (2F 10. 2) ’ )  AX, AY 
10(21:40) =ANN0 

WRITE (MUNIT, ’ (A40) ’ , REC=HDR+2)  10 
READ (ITD,*)  IBUT, VX, VY 
10(1:40)=’  ’ 

WRITE (10 (1:20) , ’ (2F10. £)’ )  VX,VY 
WRITE (MUNIT, ’ (A40) ’ , REC=HDR+3>  10 
HDR=HDR+3 

END  IF 

ENTRY  WILL  BE  A  LINE 


IF  (  (II 

.  EQ. 

11). 

OR.  (II 

.EQ. 

12) . 

,  OR. 

(II 

.EQ. 

13) 

.OR. 

(II 

.EQ. 

14)  . 

OR. (II 

.EQ. 

18) . 

,  OR. 

(II 

•  EQ. 

19) 

•  OR. 

(II 

.  EQ. 

20)  ) 

THEN 

10(1 

:  40)  = 

»  » 

10(1 

:  2)  =’ 

11’ 

WRITE ( 10 ( 

3:4) 

,  ’  (12)’ 

)  II 

AX,  AY 


WRITE (10 (7:20),’  (312, F4. 2, 14)’ )  WCS (I I, 1 ) , WCS ( 1 1, 2) , WCS ( 

SCALE (II), ANGLE (II) 

10(21:24)=’  0000’ 

WRITE ( 10 (25:40) , ’ (812) ’ )  LINK 
WRITE (MUNIT, ’ (A40) ’ , REC=HDR+1 )  10 
WRITE ( 10 ( 1 :20) ,  ’  (2F10.2)’)  AX,  AY 
10(21 : 40) =ANNO 

WRITE (MUNIT, ’ (A40) ’ , REC=HDR+2>  10 
10(1:40)=’  ’ 

WRITE (MUNIT, ’ (A40) ’ , REC=HDR+3>  10 
III =HDR+3 
NPTS=0 

READ (ITD,*)  IBUT, VX, VY 
IF  (IBUT  .EQ.  9)  THEN 

READ (MUNIT, ’ (A40)’ , REC=HDR+1)  10 
WRITE (10(5:6),’ (12)’)  NPTS 
WRITE (MUNIT, ’ (A40) ’ , REC=HDR+1 )  10 

WRITE(I0(1 :40) , ’ (4F10.2)’ )  VXMIN, VXMAX, VYMIN, VYMAX 
WRITE (MUNIT, ’ (A40) ' , REC=HDR+3)  10 
HDR=HDR+3+ (NPTS/2) 

RETURN 


11,3), 
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END  IF 


IF  (FLAG)  THEN 

FLAG®. FALSE. 

VXMIN=VX 
VXMAX=VX 
VYMIN=VY 
VYMAX=VY 
END  IF 

IF  (VX  .GT.  VXMAX)  VXMAX=VX 

IF  (VX  .LT.  VXMIN)  VXMIN=VX 

IF  (VY  .GT.  VYMAX)  VYMAX=VY 

IF  (VY  .LT.  VYMIN)  VYMIN=VY 

READdTD,  *)  IBUT,  VX1,VY1 
IF  (IBUT  .EQ.  9)  THEN 
10(1:40)*’  ’ 

WRITE ( 10 ( 1 :20) ,  '  (2F10. 2) ’ )  VX,VY 

JJJ*I I 1+ (NPTS/2) +1 

WRITE (MUNIT, ’  (A40)’ , REC=JJJ)  ID 

READ  (MUNI  T,  MA40)’ ,  REC=HDR+1)  10 

NPTS=NPTS+1 

WRITE (10(5:6),’ (12)’ )  NPTS 
WRITE  (MUNIT,  ’  (A40)  •  ,  REOHDR+i  )  10 

WRITE (10(1: 40) ,  ’  (4F10.  2)’ >  VXMIN,  VXMAX,  VYMIN, VYMAX 
WRITE (MUNIT, ’  (A40) ’  ,  REC=HDR+3)  10 
HDR*HDR+3+ (NPTS/2) +1 
RETURN 

END  IF 

IF  (VX1  .GT.  VXMAX)  VXMAX*VX1 

IF  (VX1  .LT.  VXMIN)  VXMIN*VX1 

IF  (VY1  .GT.  VYMAX)  VYMAX=VY1 

IF  (VY1  .LT.  VYMIN)  VYMIN*VY1 

WRITE ( 10 ( 1 :40),  ’  (4F10.2)’ )  VX, VY, VX1, VY1 

NPTS-NPTS+2 

JJJ*I 11+ (NPTS/2) 

WRITE (MUNIT, ’  (A40)  ’ ,  REC=JJJ)  10 
GOTO  100 

END  IF 

C  ENTRY  WILL  BE  A  POLYGON 

IF  ((II  .EQ.  4). OR.  (II  .EQ.  5). OR.  (II  .  EQ.  6). OR.  (II  .  EQ.  7). OR. 

*  (II  .EQ.  9). OR.  (II  .EQ.  10). OR.  (II  . EQ.  15))  THEN 
10(1:40)=’  ’ 

10(1:2)*’ 12’ 

WRITE(IQ(3:4) ,  ’  (I£)’ )  II 

WRITE (10 (7:20),’  (312,  F4.  2,  14)’ )  WCS (II, 1 ) , WCS (11,2), WCS (11,3), 

*  SCALE (II), ANGLE (II) 

10(21:24) =’0000’ 

WRITE(IO(25:40),  •  (812)’ )  LINK 
WRITE (MUNIT, ’ (A40) ’ , REC-HDR+1 )  10 
WRITE (10 (1:20),’  (2F10.2)’ >  AX, AY 
10(21: 40) =ANN0 

WRITE (MUNIT, ’ (A40) ’ , REC=HDR+2)  10 
10(1:40)=’  ’ 

WRITE (MUNIT, ’ (A40) * , REC=HDR+3)  10 

III-HDR+3 

NPTS=0 

200  READdTD,*)  IBUT,VX,VY 

IF  (IBUT  .EQ.  9)  THEN 

READ(MUNIT,’  (A40)’, REC-HDR+1)  10 
WRITE (10(5:6),*  (IS)')  NPTS 
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WRITE (MUNIT, ’  (040) »  ,  REC=HDR+1 )  10 

WRITE ( 10  < 1 : 40) , ’  (4F10.2)’ )  VXMIN, VXMOX, VYMIN, VYMOX 
WRITE (MUNIT, ’  (040) ’  ,  REC=HDR+3)  10 
HDR=HDR+3+ (NPTS/2) 

RETURN 

END  IF 

IF  (FLOG)  THEN 

FLOG=. FOLSE. 

VXMIN=VX 
VXMOX=VX 
VYMIN=VY 
VYMOX=VY 
END  IF 

IF  (VX  . GT.  VXMOX)  VXMOX=VX 

IF  (VX  .LT.  VXMIN)  VXMIN=VX 

IF  (VY  .GT.  VYMOX)  VYMOX=VY 

IF  (VY  .LT.  VYMIN)  VYMIN=VY 

READ ( ITD, *>  I  BUT, VX 1 , VY 1 
IF  ( I BUT  .EQ.  3)  THEN 
10(1:40)=’  ’ 

WRITE ( 10 ( 1 :20) , ’ (2F10. 2) ’ )  VX.VY 

JJJ=I 11+ (NPTS/2) +1 

WRITE (MUNIT, ’ (040) ’ , REC=JJJ)  10 

READ(MUNIT, ’ (040) ' , REC=HDR+1 )  10 

NPTS=NPTS+1 

WRITE(I0(5:fc) , ’ (12)’ )  NPTS 
WRITE (MUNIT, ’  (040)  ’  ,  REC=HDR+1 )  10 

WRITEdOCl  :40) ,  ’  (4F10.2)’  )  VXMIN,  VXMOX,  VYMIN,  VYMOX 
WRITE (MUNIT, ’ (040)' , REC=HDR+3)  10 
HDR=HDR+3+ (NPTS/2) +1 
RETURN 

END  IF 

IF  (VXl  .GT.  VXMOX)  VXMAX=VX1 

IF  (VXl  .LT.  VXMIN)  VXMIN=VX1 

IF  (VY1  .GT.  VYMOX)  VYM0X=VY1 

IF  ( VY 1  .LT.  VYMIN)  VYMIN=VY1 

WRITE (10(1: 40) , ’ (4F10.2)*)  VX, VY, VXl , VY1 

NPTS=NPTS+2 

JJJ=I 11+ (NPTS/2) 

WRITE  (MUNIT,  MO40) ’,  REC=JJJ)  10 
GOTO  200 

END  IF 


RETURN 

END 

SUBROUTINE  TIME(STOMP) 

C  THIS  SUBROUTINE  DISPLAYS  THE  TIME  ON  THE  SCREEN  WITH 
C  THE  COMMAND  MENU  PRESENT 

CHARACTER* 15  STAMP 

INTEGER'  HOUR, MINUTE, SECOND 

C0MM0N/TIM1 /HOUR, MINUTE, SECOND 

C  GET  THE  TIME  FROM  THE  SYSTEM 
CALL  RTIME 

STAMP (1:15)=’  ’ 

C  GENERATE  THE  TIME  STAMP 

STAMP (3:3)  =  ’ :’ 

STAMP (6:6)  =  ’ 
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WRITE (STAMP <1:2), 1 )  HOUR 
WRITE (STAMP <4: 5) , 1 )  MINUTE 
WRITE (STAMP (7: 8) , 1)  SECOND 
FORMAT (12) 


FILL  IN  ANY  BLANKS  WITH  A  0 


IF 

(STAMP (1:1)  .EQ. 

J 

9 

) 

STAMP (1:1) 

= 

»  0* 

IF 

(STAMP (2:2)  . EQ. 

f 

1 

) 

STAMP (2:2) 

=s 

*  0» 

IF 

(STAMP(4:4)  . EQ. 

9 

9 

) 

STAMP(4:4> 

= 

’  0» 

IF 

(STAMP (5:5)  .  EQ. 

9 

9 

) 

STAMP (5:5) 

= 

*  0* 

IF 

(STAMP (7:7)  .  EQ. 

9 

9 

) 

STAMP (7:7) 

= 

»  0* 

IF 

(STAMP (8:8)  .  EQ. 

9 

9 

) 

STAMP (8:8) 

= 

*  0» 

RETURN 

END 

SUBROUTINE  DATE (STAMP) 


CHARACTER* 15  STAMP 

INTEGER  MONTH, DAY, YEAR, DOW 

COMMON  /DAT 1 /DOW, YEAR, MONTH, DAY 

CALL  RDATE 

STAMP (1:15)=’  ’ 

STAMP (3:3) =’ /’ 

STAMP (6:6)=’ /’ 

WRITE (STAMP (1:2), 5)  MONTH 
WRITE (STAMP (4: 5), 5)  DAY 
WRITE (STAMP (7 : 8) , 5)  YEAR 
FORMAT (A2) 

RETURN 

END 


n  n  ro  n  n  n 


C 


CLEAR  THE  SCREEN  AFTER  OBTAINING  THE  USERS  INPUT  AND  OPEN  THE  HELP  FILE 
CALL  CLEAR (7,0) 

OPEN  (HUNIT, FILE=HFILE, STATUS®’ OLD’ ) 


C  SET  UP  THE  SEARCH  KEY  *#*  TO  FIND  THE  REQUIRED  PART  OF  THE  FILE 
TLINEU  :80>  =’  *X*’ 

TL I NE ( 2 : 2 ) =CMD ( 1 ) 

5  READ  (HUNIT,  ’  -.A80)  ’  )  LINE 

C  A  MATCH  WAS  FOUND  TO  *#* 

IF  (TLINE ( 1 : 3)  . EQ.  LINE(ls3>>  THEN 

C  FIND  THE  NUMBER  OF  LINE  OF  TEXT  THAT  NEEDS  TO  BE  DISPLAYED 

READ ( L I NE (4:5),’ (12)’)  IG 


J=0 

DO  £0  1=1, IG, 1 

READ  (HUNIT,  MA80)  ’  )  LINE 
J=J+1 

C  DISPLAY  THE  LINE  OF  TEXT  ON  THE  SCREEN 

CALL  MENUDR(LINE, J, 1,2, 0, 1, 1) 

C  CAN  ONLY  DISPLAY  22  LINES  ON  THE  SCREEN  AT  A  TIME 

IF  (J  .EQ.  22)  THEN 

C  DETERMINE  IF  THERE  IS  MORE  TEXT  TO  BE  PRINTED 

IF  (I  .EQ.  IG)  THEN 

DISPLAY  THE  END  OF  FILE  MESSAGE  TO  INDICATE  THAT 

THIS  IS  THE  END  OF  THE  HELP  FILE 

CALL  MESS  (19,  RC  (3,  1 ) ,  RC  (3,  2) ,  RC  (3,  3> ,  6) 

READ  < ITR, ’  (Al)’ >  CMD ( 1 ) 

CLOSE  (HUNIT) 

GOTO  1 

ELSE 

DISPLAY  MESSAGE  PRESS  RETRUN  TO  CONTINUE 
CALL  MESS  < 16, RC (3, 1 ) , RC (3, 2) , RC (3,  3) ,  6) 

READ (ITR, ’ (Al)’ )  CMD(1> 

CALL  CLEAR (7,0) 

J=0 

END  IF 
END  IF 

0  CONTINUE 

DISPLAY  END  OF  FILE  MESSAGE  TO  INDICATE  NO  MORE  HELP  TEXT 
AVAILABLE. 

CALL  MESS (19,  RC (3,  1 ) ,  RC (3, 2) , RC (3, 3) , 6) 

READ (ITR, ’ (Al)8 )  CMD ( 1 ) 

CLOSE  (HUNIT) 

GOTO  1 

ENDIF 

C  KEY  DID  NOT  MATCH,  GO  AND  TRY  ANOTHER  LINE 
GOTO  5 
END 

SUBROUTINE  TIME (STAMP) 


C*#*****#**#*******#****#***##*#**##***#**###**##*###***#*######*#*#**##****##* 
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C  THIS  SUBROUTINE  GETS  THE  TIME  FROM  THE  SYSTEM  AND  PASSES  IT  BACK  IN  STAMP 
C  THE  TIME  IS  PASSED  BACK  IN  THE  FORM  HHtMMiSS 

C****************************************************************************** 


CHARACTER* 15  STAMP 

INTEGER  HOUR,  MINUTE,  SECOND, DOW, YEAR, MON, DAY 

COMMON/TIM1 /HOUR,  MINUTE,  SECOND 

C  GET  THE  TIME  FROM  THE  SYSTEM,  RTIME  IS  A  68000  ASSEMBLER  PROGRAM 

C  DATA  IS  PASSED  IN  THE  COMMON  BLOCK  TIM1 

CALL  RTIME 

C  GENERATE  THE  TIME  STAMP 

STAMP ( 1 : 15) *’  * 

STAMP (3:3)  ■  ’ 

STAMP (6:6)  =  * :» 

WRITE (STAMP (1:2), 1 )  HOUR 
WRITE (STAMP (4:5) , 1 )  MINUTE 
WRITE (STAMP (7:8) , 1)  SECOND 
1  FORMAT (12) 

C  FILL  IN  ANY  BLANKS  WITH  A  0 


IF 

(STAMP (1:1)  .EQ. 

« 

’ ) 

STAMP (1:1) 

■ 

« 

IF 

(STAMP(2:2)  .  EQ. 

9 

» ) 

STAMP (2: 2) 

s 

*0* 

IF 

(STAMP(4:4)  .  EQ. 

9 

• ) 

STAMP (4:4) 

m 

*  0* 

IF 

(STAMP (5:5)  . EQ. 

9 

* ) 

STAMP (5: 5) 

a 

1 0i 

IF 

(STAMP (7: 7)  . EQ. 

9 

' ) 

STAMP (7:7) 

■ 

’0* 

IF 

(STAMP (8:8)  .  EQ. 

9 

» ) 

STAMP (8: 8) 

m 

«0» 

RETURN 

END 

SUBROUTINE  DATE (STAMP) 


C****************************************************************************** 
C  THIS  ROUTINE  OBTAINS  THE  DATE  FROM  THE  SYSTEM  AND  RETURNS  IT  IN  STAMP 
C  THE  DATE  IS  RETURNED  IN  THE  FORM  MM/DD/YY 

C****************************************************************************** 


CHARACTER* 15  STAMP 

INTEGER  HOUR,  MINUTE,  SEC,  DOW,  YEAR,  MON, DAY 

COMMON/DAT1/DOW,  YEAR,  MON, DAY 

C  GET  THE  DATE  FROM  THE  SYSTEM,  RDATE  IS  A  68000  ASSEMBLER  PROGRAM 

C  THE  DATA  IS  PASSED  THROUGH  THE  COMMON  BLOCK  DAT1 

CALL  RDATE 

C  FORM  THE  DATE 

STAMP ( 1 : 15) *»  * 

STAMP (3:3) =’  /’ 

STAMP (6:6) =’  /* 

WRITE (STAMP ( 1 :2) , 5)  MON 
WRITE (STAMP (4: 5) , 5)  DAY 
WRITE (STAMP (7: 8) ,5)  YEAR 
5  FORMAT (12) 

RETURN 

END 

SUBROUTINE  DBMM ( ITR,  CUN IT,  SUN IT 1,  SUNIT2, SUNIT3, SUNIT4, 

*  CFILE, SFILE1,  SFILE2, SFILE3, SFILE4, 

*  SHFILE,  PUNIT1,  PUNIT2, PFILE1, PHFILE, 
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SMUNIT, SMFILE) 


C****************************************************************************** 
THIS  SUBROUTINE  MANAGES  THE  SUBSTANCE-SOURCE  AND  PROCEDURE  DATA  BASES 
VARIABLES  PASSED: 

ITR  -  INTERACTIVE  TERMINAL  READ  UNIT 

SMUNIT  -  UNIT  TO  OPEN  THE  MENU  FILE  (SMFILE)  ON 

SMFILE  -  MENU  FILE  NAME 

SHFILE  -  SUBSTANCE-SOURCE  HELP  FILE  NAME 

SUN IT 1  -  UNIT  #  TO  OPEN  SFILE1  ON 

SUN ITS  -  UNIT  #  TO  OPEN  SFILE2  ON 

SUNIT3  -  UNIT  #  TO  OPEN  SFILE3  ON 

SUNIT4  -  UNIT  #  TO  OPEN  SFILE4  ON 

PHFILE  -  PROCEDURE  HELP  FILE  NAME 

PUNIT1  -  UNIT  #  TO  OPEN  PFILE1 

PUNIT2  -  UNIT  #  TO  OPEN  PROCEDURE  FILE  OF  INTEREST  ON 

PFILE1  -  FILE  NAME  CONTAINING  LIST  OF  PROCEDURE  CURRENT  PROCEDURE 


FILES 

****************************************************************************** 


INTEGER  ITR, CUNIT, SUNIT1 , SUNIT2, SUNIT3, SUNIT4, PUNIT1, PUNIT2, 

*  SMUNIT, RC (2, 3) 

CHARACTER* 1  CMD ( 1 ) 

CHARACTER*?  CFILE,  SFILE1,  SFILE2, SFILE3, SFILE4, SHFILE, PFILE1, 

*  PHFILE, SMFILE 

DISPLAY  THE  MAIN  MENU  AND  INPUT  USER  SELECTION 
CALL  MENUSV (SMFILE,  120, RC,  2,  SMUNIT) 

10  CMD ( 1 ) =’  » 

CALL  MENURD(RC,  2,  1,  1,CMD,  ITR) 

C  CHECK  FOR  VALID  INPUT 

IF  (INDEX  (M2X’ ,  CMD(l)  )  .  EQ.  0)  THEN 

CALL  MESS ( 1 1, RC (2, 1 ) , RC (2, 2) , RC (2, 3) , 6) 

GOTO  10 

END  IF 

C  THE  USER  SELECTED  THE  SUBSTANCE-SOURCE  DATA  BASE 

IF  (CMD  ( 1 )  .EQ.  MM  CALL  SSSIP  ( ITR,  SUNIT1,  SUNIT2,  SUNIT3,  SUNIT4, 

*  SFILE1 , SFILE2, SFILE3, SFILE4, 

*  SHFILE, SMUNIT,  SMFILE) 

C  THE  USER  SELECTED  THE  PROCEDURE  DATA  BASE 

IF  (CMD  < 1 )  .EQ.  ’  2'  )  CALL  PROCD ( ITR,  PUNIT1 ,  PUNIT2, PFILE1, PHFILE, 

*  SMUNIT, SMFILE) 

C  THE  USER  SELECTED  TO  RETURN 

IF  (CMD ( 1 )  .EQ.  *XM  RETURN 


GOTO  5 
END 


PROGRAM  SYMBOL 


C 


CHARACTER#40 

CHARACTER*20 

INTEGER 

REAL 


FNAME 

10 

ITW, ITR, SUNIT, SN, WT, COLOR, STYLE, ANGLE 
SCALE 


ITW=1 
ITR=1 
SUN I T= 14 

INPUT  THE  SYMBOL  FILE  NAME 

WRITEdTW,  ’(/,”  ENTER  THE  SYMBOL  FILE  NAME”)’) 
READdTR,  ’  <A40>’ )  FNAME 


OPEN  (SUNIT, FILE=FNAME,  STATUS=’  NEW’ , ACCESS=’ DIRECT’ , RECL=£0, 
*  FORM=’ FORMATTED’ ) 


100 


10(1:20;=’  ’ 

WRITE (SUNIT, ’ ( A20) ’ , REC=1 )  10 
ICNT =0 

WRITE ( ITW, *  (”  ENTER  SYMBOL  NUMBER  ,  -999  TO  QUIT”)’) 

READ (ITR,*)  SN 

IF  (SN  .EQ.  -999)  THEN 


’ (!£>’)  ICNT 


10(1:20)=’  ’ 

WRITE (10(1:2), 

WRITE (SUNIT, ’  < A20) ’ , REC=1 ) 
CLOSE  (SUNIT) 

STOP 
END  IF 

WRITEdTW,  ’  (’’ENTER  WEIGHT”)’) 

WT 

(’  ’  ENTER  COLOR’  ’  )  ’  ) 

COLOR 


READ (ITR, *) 
WRITEdTW,  ’ 

READ ( ITR, *) 
WRITEdTW,  ’  (’’ENTER 
READ (ITR, *)  STYLE 
WRITEdTW,  ’  (’  ’  ENTER 
READdTR,  ’  (F10.0)’  ) 
WRITEdTW,  ’  (’’ENTER 
READdTR,*)  ANGLE 


STYLE’ ’ > ’ ) 

SCALE’ ’ ) ’  ) 
SCALE 
ANGLE’ * ) ’  ) 


10 


ICNT=ICNT+1 
10(1:20)=’  ’ 

WRITE (10 ( 1 : 16), ’ (412, F4. 2, 14) ’ >  SN, WT, COLOR, STYLE, SCALE, ANGLE 
WRITE (SUNIT, ’  (A20)  ’  ,  REC=ICNT+1 )  10 
GOTO  100 


END 
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PROGRAM  CNVRT 


CHARACTER*80  LINE 
CHARACTER*40  FINt  FOUT 
CHARACTER*20  FTYPE 
CHARACTER*5  FMT 
CHARACTER* 1  TYPE 

WRITE(0, ’(//, ’’ENTER  FILE  TO  BE  CONVERTED  TO  DIRECT”)’) 

READ (0, ’ (A40) ’ )  FIN 

WRITE(0,’  (//.’’ENTER  NEW  FILE  NAME  OF  DIRECT  FILE”)’) 

READ (0, *  (A40) ’ )  FOUT 

WRITE(0,’  (//.’’ENTER  DESIRED  OUTPUT  RECL  LENGTH”)’) 

READ (0, *)  I  RECL 

WRITE(0,’  (//.’’OUTPUT  FILE  FORMATTED  OR  UNFORMATTED  (F  OR  U)  ”  ) ’ ) 
READ (0, ’ (A1 ) ’ )  TYPE 

FTYPE*’ UNFORMATTED’ 

IF  (TYPE  .EQ.  ’F’)  FTYPE*’ FORMATTED’ 

IREC1=IRECL 

IF  (TYPE  .EQ.  ’F’)  IRECl=IRECL+2 
OPEN  ( 12. FILE=FIN, STATUS*’  OLD* ) 

OPEN  ( 13, FILE=FOUT,  STATUS*’ NEW’ , ACCESS*’ DIRECT’ , RECL=IREC1, 

*  FORM=FTYPE) 

FMT*’  ( AXX )  ’ 

WRITE (FMT (3:4), ’(12)’)  I RECL 
1  =  1 

50  READ ( 12, ’ (A80) ’ , END=100)  LINE 
IF  (TYPE  .EQ.  ’F’)  THEN 

WRITE (13, FMT, REC=I)  LINE ( 1 : IRECL) 

ELSE 

WRITE ( 13, REC-I)  LINE ( 1 : IRECL) 

END  IF 

1  =  1  +  1 
GOTO  50 

100  WRITE (0,  ’  ( //, 13,  ’  ’  RECORDS  WERE  PROCESSED”  )* >  1-1 
CLOSE  (12) 

CLOSE  (13) 

STOP 

END 
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INTEGER  FUNCTION  BNDX (STR, N) 

CHARACTER* (*)  STR 
INTEGER  N,  I 

DO  5  I=N, £, -1 

IF  (STR (1:1)  .  NE.  '  ’)  GOTO  id 
CONTINUE 


BNDX=1 

RETURN 

END 
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♦segment  *menuseg 

SUBROUTINE  MENUSV (FNAME,  MN,  RC,  N, INU) 


C***************************************************************************  * 


c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 


THIS  SUBROUTINE  DISPLAY  THE  MENUS  ON  THE  SCREEN  AND  LOADS  AN  ARRAY  WITH  THE 
INPUT  FIELD  DATA.  IT  ALSO  INITIALLY  CONVERTS  THE  FILE  TO  DIRECT  ACCESS  THE 
FIRST  TIME  IT  IS  CALLED. 

VARIABLES  PASSED: 


FNAME 

MN 

RC 


INU 


MENU  FILE  NAME 

MENU  NUMBER  TO  BE  DISPLAYED 

ARRAY  TO  LOAD  WITH  THE  INPUT  FIELD  DATA 

RC (N, 1 )  -  ROW  POSITION  OF  THE  INPUT  FIELD 

RC (N, 2)  -  COLUMN  POSITION  OF  THE  INPUT  FIELD 

RC(N, 3)  -  LENGTH  OF  THE  INPUT  FIELD 

UNIT  #  TO  OPEN  THE  MENU  FILE  ON 


C*#** ************************************************************ ***********  * 


C 


C 


CHARACTER* (*) 
CHARACTER *00 
CHARACTER*3 


FNAME 

LINE  < 1 > , SCREEN <24 ) , LINE1 
ID 


INTEGER  MN,  INU,  ROW,  COL,  RC (N,  3> ,  STATE,  IS,  INX,  L,  MIND (50) 

LOGICAL  MREAD 


COMMON/MENIJS/  MREAD 


OPEN  THE  MENU  FILE  DIRECT  ACCESS  (INITIALLY  SEQUENTIAL) 

OPEN  (INU, F ILE=FNAME,  ERR=100,  ACCESS=’ DIRECT’ , RECL=B0> 

FORM  A  DIRECT  ACCESS  ARRAY  ON  THE  FIRST  TIME  THIS  ROUTINE  IS  CALLED. 
IF  (MREAD)  THEN 


C 


SET  THE  INDICATOR  SO  NO  MORE  CONVERSIONS  TAKE  PLACE 
MREAD=. FALSE. 


C  SET  THE  INDEX  AND  RECORD  TO  1 

ICNT=1 

IREC=1 


C  READ  IN  THE  MENU  HEADERS  (**###**) 

5  READ ( INU,  REC=IREC,  ERR=200)  LINE(l) 

C  CONVERT  ###  TO  AN  INTEGER  VALUE 

READ (LINE ( I ) (3:5) , ’ ( 13) ’ )  MIND ( ICNT) 

C  INCREMENT  THE  ARRAY  INDEX  AND  THE  RECORD  COUNTER,  THE  NEXT 

C  HEADER  RECORD  IS  £4  AWAY 

ICNT=  ICNT+1 
I REC=  IREC+E4 
GO  TO  5 
END  IF 


C  DETERMINE  WHICH  MENU  HAS  BEEN  SELECTED  AND  DETERMINE  RECORD  NUMBER 
£«0  DO  10  1  =  1, 50,  1 

IF (MIND < I )  .EO.  MN)  GOTO  12 
10  CONTINUE 
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FORM  THE  RECORD  NUMBER  AND  CLOSE  THE  MENU  FILE 
IREC*  < 1-1 ) #24  +1 
CLOSE (INU) 

OPEN  THE  MENU  FILE  AND  CLEAR  THE  SCREEN 

OPEN  (INU,  FILE=FNAME,  ERR=100,  ACCESS®’ DIRECT’ , RECL=B0> 

CALL  CLEAR (7,0) 

PROCESS  THE  MENU,  DISPLAY  TEXT  ON  THE  SCREEN  AND  FORM  THE  INPUT  FIELDS 
DO  15  ROW®!, 23,  1 
IREC®  IREC+1 
STATE® 1 

READ (INU, REC® I REC, ERR® 1 00 >  LI NE ( 1 > 

SET  THE  COLUMN  COUNTER  TO  THE  FIRST  COLUMN 

C0L®1 

JJ®  COL+l 

STATE  1  IS  THE  INITIAL  STATE  IS  IS  REMAINED  IN  UNTIL  A  NON  BLANK 
CHARACTER  IS  ENCOUNTERED 
IF  (  STATE. EQ. 1  )  THEN 

IF  (LINE(l) (COL:COL>  .  NE.  ’  *)  THEN 
IF  (LINE(l) (COL:JJ)  .EQ.  ’ **’ >  THEN 

STATE=2 
ELSE 
STATE=3 
IS®CDL 
END  IF 
END  IF 

ENDIF 


IF  (STATE. EQ.  3  )  THEN 

IF  (LINE(l) (COLsCOL)  .EQ.  ’  ** )  THEN 
IF  (LINE(l) (JJ:JJ)  .EQ.  ’*’>  THEN 

SCREEN (ROW) ( IS:COL-l ) =LINE ( 1 ) (IS:COL-l) 

Jl*COL-l 

LINE1*LINE ( 1 ) 

CALL  MENUDR (LINE1 ( IS : J1 ) ,  ROW,  IS,  1,0,  1,  1) 
STATE=2 

ENDIF 

ENDIF 


ENDIF 


IF  (STATE  .EQ.  2)  THEN 

IF  (LINE(l) (C0L+4sC0L+4)  .  NE.  ’  %’ )  GOTO  100 
IF  (LINE(l) (C0L+7sC0L+B)  . NE.  ’  %%’  >  GOTO  100 
READ (LINE ( 1 ) (C0L+2:C0L+3> , ' < 12) * , ERR®100>  INX 
READ(LINEU)  (C0L+5:C0L+6>  r  ’  ( 12)  ’  ,  ERR*100)  L 
RC(INX, l)=ROW 
RC  ( INX,  2)  «COL 
RC  ( INX,  3)  =L 
STATE® 1 
C0L®C0L+8 

ENDIF 

INCREMENT  THE  COLUMN  COUNTER  AND  TEST  IF  THIS  IS  THE  LAST  COLUMN 

COL-COL+1 

IF  (COL  .LE.  80)  GOTO  20 

NO  MORE  DATA  LEFT  IN  THE  RECORD,  BUT  THERE  MAY  BE  DATA  IN  LINE(l) 

THAT  NEEDS  TO  BE  OUTPUT 
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IF  (STATE  .EQ.  3)  THEN 

SCREEN (ROW) ( IS: 80) =LINE ( 1 > (IS:80) 

LINE1=LINE ( 1 ) 

CALL  MENUDR (LINE1 (IS:80),ROW,  IS, 1,0,  1,  1) 

END  IF 

15  CONTINUE 

C  CLOSE  THE  FILE  FROM  EITHER  NORMAL  OR  ABNORMAL  TERMINATION 
100  CLOSE  (INU) 

RETURN 

END 

SUBROUTINE  MENUWR (RC,  N,  IS,  IE,  TEXT, ICLR, ICOLOR,S> 

C************************** ******** ******************************************** 
THIS  SUBROUTINE  DISPLAYS  AN  ARRAY  OF  TEXT  ON  THE  SCREEN  AT  THE  ROW  AND 
COLUMN  POSITONS  AND  LENGTHS  AS  GIVEN  IN  THE  RC  ARRAY.  THE  ADDRESSING  INTO 
THE  TEXT  ARRAY  IS  EITHER  RELATIVE  OR  ABSOLUTE 
VARIABLES  PASSED: 

RC  -  ARRAY  TO  HOLD  THE  INPUT  FIELD  DATA 

RC (N,  1 )  -  ROW  POSITION  OF  INPUT  FIELD 
RC (N, 2)  -  COLUMN  POSITION  OF  INPUT  FIELD 
RC (N, 3)  -  LENGTH  OF  INPUT  FIELD 
N  -  SIZE  OF  THE  RC  ARRAY  IN  THE  FIRST  INDEX 

IS  -  STARTING  INDEX  (RELATIVE)  INTO  THE  TEXT  ARRAY 

IE  -  ENDING  INDEX  (RELATIVE)  INTO  THE  TEXT  ARRAY 

TEXT  -  ARRAY  OF  THE  CHARACTER  DATA  TO  BE  DISPLAYED  ON  THE  SCREN 
ICLR  -  FLAG  TO  INDICATE  WHETHER  THE  SCREEN  IS  CLEARED 
1  ==>  CLEAR  THE  SCREEN 

==>  NOT  TO  CLEAR  THE  SCREEN 
ICOLOR  -  COLOR  OF  THE  DISPLAYED  TEXT 

S  -  STATUS  ARRAY  USED  TO  PASS  PARAMTERS  TO  MENUDR 

S(l)  -  USED  TO  INITIALZE  PAGE  ARRAY  AND  WRITE  PAGE  ARRAY 

S (2)  -  USED  TO  PASS  UNIT  #  OF  ARCHIVE  FILE 

S  (3)  -  INDICATE  RELATIVE  OR  ABSOLUTE  ADDRESSING  IN  TEXT  ARRAY 

0  ==>  ABSOLUTE  ADDRESSING 
==>  RELATIVE  ADDRESSING 
C***  *************************************************************************** 

CHARACTER* (*)  TEXT(l) 

INTEGER  IS, IE, ICLR, ICOLOR, RC (N, 3) , K, N, S ( 1 > 

C  IF  ICLR  =  1  THEN  CLEAR  THE  SCREEN 
IF  (ICLR  .EQ.  1)  CALL  CLEAR (7,0) 

C  OUTPUT  THE  LINES  OF  TEXT 
IF  (S (3)  .EQ.  0)  THEN 

RELATIVE  ADDRESSING  MODE  TO  BE  USED 
DO  5  K=IS, IE, 1 

CALL  MENUDR (TEXT (K) ( 1 : RC (K, 3) ) , RC (K, 1 ), RC (K, £>, ICOLOR, S ( 1 ) , 

S (2) , 1) 

CONTINUE 


C  RELATIVE  ADDRESSING  MODE  IS  TO  BE  USED 

L-IE-IS+1 
DO  10  K°1,L,  1 
J«IS+(K-1) 


C 

* 

5 
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10 


COLL  MENUDR (TEXT (K) ( 1 : RC ( J, 3) > , RC ( J, 1),RC(J,2>, ICOLOR.S(l), 
S (2) , 1 ) 

CONTINUE 

END  IF 


RETURN 

END 

SUBROUTINE  MENURD(RC,N,  IS,  IE, TEXT, ITT) 

C***************************************** ************************************* 
THIS  SUBROUTINE  DISPLOYS  DOTO  IN  THE  INPUT  FIELDS  OND  INPUTS  DOTA  FROM  THE 
INPUT  FIELDS 

VARIABLES  PASSED i 


RC  -  ARRAY  THAT  HOLDS  THE  INPUT  FIELD  DATA 

RC (N,  1 )  -  ROW  POSITION  OF  THE  INPUT  FIELD 
RC (N, 2)  -  COLUMN  POSITION  OF  THE  INPUT  FIELD 
RC (N,  3)  -  LENGTH  OF  THE  INPUT  FIELD 
N  -  SIZE  OF  FIRST  POSITION  OF  THE  RC  ARRAY 

IS  -  STARTING  INDEX  (RELATIVE)  INTO  THE  TEXT  ARRAY 

IE  -  ENDING  INDEX  (RELATIVE)  INTO  THE  TEXT  ARRAY 

TEXT  -  ARRAY  TO  HOLD  THE  INPUTTED  DATA 

ITT  -  FLOG  TO  INDICATE  RELATIVE  OR  ABSOLUTE  ADDRESSING 
>  =  0  ==>  ABSOLUTE  ADDRESSING 

==>  RELATIVE  ADDRESSING 
C****************************************************************************** 


CHARACTER* (*) 

CHARACTER*80 

CHARACTER*5 


TEXT ( 1 ) 

BK,  UN,  INPUT 
FMT 


INTEGER 


IS,  IE,  L,  K,  ITR,  J,  BNDX,  ID,  N,  M,  RC  (N,  3) ,  ITT 


C  INITIALIZE  THE  VARIABLES  BK  TO  BLANKS  AND  UN  TO  UNDERSCORES 
IUN=  95 
DO  3  1  =  1,80,  1 
BK ( I i I ) =  *  * 

UN ( I s I ) =  CHOR(IUN) 

3  CONTINUE 

C  SET  THE  INTERACTIVE  TERMINAL  READ  UNIT  TO  0  SINCE  0  AND  -0  ORE  THE  SAME 
ITR=0 

C  CHECK  FOR  THE  TYPE  OF  ADDRESSING,  RELATIVE  OR  ABSOLUTE 
IF  (ITT  .GE.  0)  THEN 

C  ABSOLUTE  ADDRESSING  SELECTED  IN  THE  TEXT  ARRAY 

DO  5  K=IS, IE, 1 

C  BUILD  THE  FORMAT  STATEMENT 

FMT»«  (AXX) 1 
L=RC (K, 3) 

WRITE (FMT (3i 4) , ’ (12)' >  L 

C  SET  UP  THE  LINE  FOR  INPUT,  INTITIOLLY  DISPLAY  UNDERSCORES 

CALL  MENUDR (UN ( 1 iL) , RC <K, 1 ) , RC (K, 2) , 1,0, 1, 1) 

C  SEE  IF  THERE  IS  ALREADY  DATA  STORED  FOR  THIS  INPUT  FIELD 

IF  (TEXT (K) ( 1 iL)  .EQ.  BK(liL))  THEN 
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C 


SINCE  NO  DATA  ALREADY  STORED,  HIGHLIGHT  THE  FIRST  UNDERSCORE 
CALL  MENUDR (UN (1:1), RC<K,  1 ) ,  RC  (K,  2> ,  7,  0,  1 ,  1  > 

ID=1 

ELSE 

DATA  ALREADY  STORED,  WRITE  IT  OUT  INTO  THE  UNDERSCORES  FOR  AS 
MANY  NON  BLANKS  IT  CONTAINS 
J=BNDX (TEXT (K) , L) 

CALL  MENUDR  (TEXT  (K)  (1:J),RC(K,  1),RC(K,2),  1,0,  1,  1) 

CALL  MENUDR (TEXT (K)  (1 :1>,  RC(K,  1 ) , RC (K, 2) ,  7,  0,  1,  1) 

ID=0 

ENDIF 

MOVE  THE  CURSOR  TO  THE  FIRST  POSITION  OF  THE  INPUT  FIELD  IN  REVERSE 
VIDEO 

CALL  MENUDR ('  'v» ,  RC(K,  1),  RC(K,  2>,7,  0,  1,  1) 

READ  IN  THE  RESPONSE 
READ ( ITR, *  ( A80) ’ )  INPUT 

CHECK  TO  SEE  IF  THE  NEW  INPUT  DATA  IS  BLANK  OR  NOT 
IF  (INPUT (1:L)  .NE.  BK(lsL))  THEN 

INPUT  WAS  NOT  BLANK,  SO  DISPLAY  IT  AND  MOVE  ON  TO  THE  NEXT  INPUT 
FIELD 

TEXT (K) (1 :L) = INPUT (1 :L) 

CALL  MENUDR (TEXT (K> (1:L),RC(K, 1), RC(K,2>, 1,0, 1, 1) 

ELSE 

INPUT  WAS  BLANK,  DETERMINE  IF  THE  ORIGINAL  DATA  WAS  BLANK  OR  NOT 
IF  BLANK,  THEN  BLANK  THE  INPUT  FIELD,  OTHERWISE  DISPLAY  THE  OLD 
DATA 

IF  (ID  .EQ.  1)  CALL  MENUDR (BK ( 1 :L) ,  RC (K, 1 ) , RC (K, 2) , 1,0, 1, 1 ) 

IF  (ID  .EQ.  0)  CALL  MENUDR (TEXT (K)  ( 1 :L> , RC (K,  1 ), RC (K, 2) ,  1, 0,  1,  1 ) 

ENDIF 

5  CONTINUE  ' 

ELSE 

C  RELATIVE  ADDRESSING  WAS  SELECTED,  OTHERWISE  SAME  AS  ABOVE 

LL=IE-ILU 
DO  10  J=1,LL, 1 
K=IS+(J-1) 

C  BUILD  THE  FORMAT  STATEMENT 

FMT=» (AXX) 1 
L=RC(K, 3> 

WRITE (FMT (3:4),’ (12)’)  L 

C  SET  UP  THE  LINE  FOR  INPUT 

CALL  MENUDR(UN(1 sL) , RC(K, 1), RC(K,£), 1,0, 1, 1) 

IF  (TEXT(J)  <1:1.5  .  EQ.  BK(1:L>)  THEN 

CALL  MENUDR (UN ( 1 : 1 ) ,  RC (K, 1 ) , RC (K, 2) , 7, 0, 1, 1 ) 

ID*1 

ELSE 

JJ*=BNDX  (TEXT  ( J) ,  L) 

CALL  MENUDR (TEXT (J)  (liJJ),  RC(K, 1>, RC(K,2), 1,0, 1, 1) 

CALL  MENUDR (TEXT  < J) ( 1 1 1 > ,  RC (Kt 1 > ,  RC (K,  2) ,  7,  0,  1 ,  1 ) 

ID*0 

ENDIF 

CALL  MENUDR  (’  'V| ,  RC  (K,  l ) ,  RC  (K,  2) ,  7,  0,  1,  1) 
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READ  IN  THE  RESPONSE 
READ ( ITR,  *  (A80) * )  INPUT 
IF  ( INPUT (1:L>  .NE.  BK ( 1 :L) )  THEN 
TEXT ( J) ( 1 sL) “INPUT ( 1 :L) 

CALL  MENUDR(TEXT (J) (1:L),  RCCK,  1 ) ,  RC (K,  £> ,  1, 0,  1,  1) 

ELSE 

IF  (ID  .EQ.  1)  CALL  MENUDR (BK ( 1 sL) , RC (K, 1 ) , RC (K, 2) , 1, 0, 1, 1 ) 

IF  (ID  .EQ.  B)  CALL  MENUDR (TEXT (J) (IsL), RC(K, 1), RC(K,2), 1,0,  1,  1) 

ENDIF 

10  CONTINUE 

ENDIF 

RETURN 

END 

SUBROUTINE  MENUCK ( IN, OUT, N,  FMT, EFLAG) 

C**************************************************************************** 
THIS  SUBROUTINE  CONVERTS  THE  CHARACTER  DATA  IN  THE  ARRAY  IN  TO  REAL  DATA 
DATA  IN  THE  OUT  ARRAY 
VARIABLES  PASSED: 

IN  -  ARRAY  OF  TEXT  TO  BE  CONVERTED  TO  REAL  DATA 

N  -  SIZE  OF  THE  TEXT  ARRAY,  AND  THE  NUMBER  OF  ELEMENTS  TO  CONVERT 

FMT  -  NOT  USED 

VARIABLES  RETURNED: 

OUT  -  ARRAY  OF  CONVERTED  CHARACTER  DATA  (REAL) 

EFLAG  -  FLAG  TO  INDICATE  WHETHER  ANY  ERRORS  OCCURED  IN  CONVERSION 
0  ==>  NO  CONVERSION  ERRORS 

I  ==>  INDEX  OF  THE  DATA  ITEM  A  CONVERSION  ERROR  OCCURRED 
C*************************************************************************##* 

CHARACTER* (*)  IN (N), FMT 
CHARACTER*80  TEMP 

INTEGER  N, EFLAG, I, L 

REAL  OUT (N) 

C  INITIALIZE  THE  ERROR  FLAG  TO  NO  ERRORS 
EFLAG=0 

C  DETERMINE  THE  LENGTH  OF  THE  CHARACTER  DATA 
L*LEN(IN(1) ) 

C  CONVERT  THE  CHARACTER  DATA  TO  REAL  DATA 
DO  5  1*1, N, 1 

TEMP (1:80)=*  ’ 

C  IF  NO  DECIMAL  POINT  PRESENT  THEN  PUT  ONE  IN 

IF  (INDEX ( IN( I) , * .  ’  )  .EQ.  0)  THEN 
TEMP (L+l :L+i ) =’ . * 

TEMP(1 «L)=IN(I) 

ELSE 


TEMP ( 1 iL) *IN  < I ) 


ENDIF 


C  CONVERT  THE  CHARACTER  DATA  TO  REAL 

READ ( TEMP (1:80),  ’  (F80.  1)»,ERR=10)  OUT(I) 

5  CONTINUE 

RETURN 

C  SET  THE  ERROR  FLAG  TO  THE  INDEX  WITH  THE  CONVERSION  ERROR 

10  EFLAG=I 

RETURN 
END 

SUBROUTINE  MENUDR (STRING,  ROW, COLUMN, FG, BG, H, W) 

C****************************************************************************** 
C  THIS  SUBROUTINE  MOVES  THE  CURSOR  TO  THE  ROW  AND  COLUMN  POSITON  OF  THE  SCREEN 
C  AS  DESCRIBED  BY  ROW  AND  COLUMN.  R0W=1, 2, 3, . . . , 24  AND  C0LUMN=1 , 2, 3,  . . . ,  80 
C  VARIABLES  PASSED: 

C 

C  STRING  -  TEXT  STRING  TO  BE  DISPLAYED  ON  THE  SCREEN 

C  ~  ==>  JUST  MOVE  TO  POSITION  DO  NOT  DISPLAY 

C  ROW  -  ROW  TO  MOVE  TO  ON  THE  SCREEN 

C  COLUMN  -  COLUMN  TO  MOVE  TO  ON  THE  SCREEN 

C  FG  -  COLOR  TO  DISPLAY  THE  TEXT  IN  ON  THE  SCREEN 

C  6  OR  7  -=)  REVERSE  VIDEO 

C  OTHER  ==>  NO  REVERSE  VIDEO 

C  BG  -  FLAG  TO  TELL  MENUDR  TO  STORE  OR  OUTPUT  DATA 

C  -1  ==>  INITIALIZE  PAGE  ARRAY  AND  STORE  TEXT  IN  IT 

C  -2  ==>  OUTPUT  THE  PAGE  ARRAY  TO  UNIT  H 

C  H  -  UNIT  #  THAT  ARCHIVE  FILE  IS  OPEN  UNDER 

C  W  -  NOT  USED 

C****************************************************************************** 

CHARACTER* (#)  STRING 
CHARACTER*80  PAGE ( £2 ) 

CHARACTER*4  CURSOR 

INTEGER  L,FG,BG,H,W,  ROW,  COLUMN 

C  INITALIZE  THE  PAGE  ARRAY  AND  START  STORING  TEXT 

IF  (BG  .EQ.  -1)  THEN 

DO  10  J=1 , 22, 1 

PAGE ( J) (1:80)=’  * 

10  CONTINUE 

END  IF 

C  DETERMINE  THE  STRING  LENGTH 
L=LEN (STRING) 

C  STORE  THE  TEXT  IN  PAGE  IF  THERE  IS  TEXT  TO  STORE 
IF  < (L  .NE.  0). AND. (ROW  .LT.  23)) 

*  PAGE (ROW) (COLUMN :C0LUMN+L-1 ) =STRING ( 1 :L) 

C  WRITE  THE  PAGE  FILE  TO  THE  ARCHIVE  FILE  ON  UNIT  H 
IF  (BG  .EQ.  -2)  THEN 

DO  15  Jsl, 22, 1 

WRITE (H, *  (A80) ’ )  PAGE ( J) 

15  CONTINUE 

END  IF 

C  SET  THE  CURSOR  TO  THE  DESIRED  POSITION  BY  SENDING  ESC  Y 
IESC-27 

CURSOR (1:1) -CHAR ( I ESC) 


CURS0R(2:2)«* Y* 

CURSOR (3:3) “CHAR ( ROWS 1 ) 

CURSOR (4:4) -CHAR ( COLUMNS 1 ) 

C  MOVE  THE  CURSOR  TO  THE  DESIRED  POSITION 
CALL  TNOUA (CURSOR, 4) 

C  OUTPUT  THE  STRING  IF  IT  IS  NOT  ' 

IF  (L  .EQ.  1)  THEN 

IF  (STRING  .EQ.  •  <w»  )  RETURN 
END  IF 

C  SET  THE  TERMINAL  INTENSITY  IN  ZENITH  MODE 
C  ESC  q  — >  REVERSE  VIDEO 

C  ESC  p  «»>  NO  REVERSE  VIDEO 

CURSOR (2 i 2) «*q» 

IF  ((FG  .EQ.  7) . OR. (FG  . EQ.  6))  CURSOR (2:2) =» p* 

CALL  TNOUA (CURSOR, 2) 

C  OUTPUT  THE  TEXT  STRING  THROUGH  THE  68000  ASSEMBLER  ROUTINE  TNOUA 
CALL  TNOUA (STRING, L) 

RETURN 

END 

SUBROUTINE  CLEAR (FG, BG) 

C****************************************************************************** 
C  THIS  SUBROUTINE  CLEARS  THE  SCREEN  BY  TRANSMITTING  AN  ESC  E  IN  ZENITH  MODE 
C  VARIABLES  PASSED: 

C 

C  FG,  BG  -  IGNORED  IN  THIS  VERSION 

C****************************************************************************** 

CHARACTER*2  TEMP 
INTEGER  FG, BG 

IESC-27 

TEMP (111) -CHAR ( IESC) 

TEMP (2:2) *’ E’ 

CALL  TNOUA (TEMP, 2) 

RETURN 

END 

SUBROUT I NE  ONOFF ( I ) 

C»«*«******«****«******«**«*****»*»*»**»»»*»»*«*«*****#****«****»*«###*«****#«« 
C  THIS  SUBROUTINE  TURNS  THE  CURSOR  EITHER  ON  OR  OFF.  ESC  x5  TURNS  THE  CURSOR 
C  OFF,  WHILE  ESC  y5  TURNS  THE  CURSOR  ON.  WHEN  TURNING  THE  CURSOR  ON,  BE  SURE 
C  TO  EXIT  REVERSE  VIDEO  MODE. 

C  VARIABLES  PASSED: 

C 

C  I  -  FLAG  TO  TURN  THE  CURSOR  ON  OR  OFF 
C  0  ««>  CURSOR  OFF 

C  1  -*>  CURSOR  ON 

C»****#**«***#****«*«*»**«*******#**«**«***««*«»«******«***««**««««««*«**««*««« 


CHARACTERS 

INTEGER 


TEMP 

I 
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C  TURN  THE  CURSOR  ON  OR  OFF 
IESC-27 

TEMP (1:1) =CHAR  < I ESC) 

TEMP (2:3) =’ x5’ 

IF  (I  .EQ.  1)  TEMP<£:£) =’ y’ 

CALL  TNOUA (TEMP, 3) 

C  BE  SURE  TO  EXIT  REVERSE  VIDEO  MODE,  SEND  AN  ESC  q 
IF  (I  .EQ.  1)  THEN 

TEMP(2:2)='q’ 

CALL  TNOUA (TEMP, 2) 

END  IF 

RETURN 

END 

SUBROUTINE  MESS ( I, R, C, L, CL) 

C****************************************************************************** 
THIS  SUBROUTINE  DISPLAY  MESSAGE  ON  THE  TERMINAL 
VARIABLES  PASSED: 

I  -  MESSAGE  INDEX 

R  -  ROW  ON  THE  SCREEN  TO  DISPLAY  THE  MESSAGE 

C  -  COLUMN  ON  THE  SCREEN  TO  DISPLAY  THE  MESSAGE 

L  -  LENGTH  OF  THE  MESSAGE  TO  BE  DISPLAYED 

CL  -  COLOR  TO  DISPLAY  THE  MESSAGE 

6  OR  7  ==>  REVERSE  VIDEO 

OTHER  ==>  NO  REVERSE  VIDEO 
C****************************************************************************** 

CHARACTER*30  MES ( £5 ) 

INTEGER  I, R, C, L, CL 

MES(l) (1:30)=’ INVALID  DATA’ 

MES (2) (1:30)=’ ENTRY  EXISTS’ 

MES(3) (1:30)=’ ADDITION  MADE’ 

MES(A) (1:30)=’  ’ 

MES (5) ( 1 : 30) =’ NOT  FOUND’ 

MES(ll) (1 :30)=’ INVALID  COMMAND’ 

MES(12) (1:30)*’ IN  ARCHIVE  MODE’ 

MES (13) (1:30)=’ ARCHIVE  MODE' 

MES<14) (1:30)=’ TOO  MANY  FILES’ 

MES (15) (1:30)=’ HELP  NOT  AVAILABLE’ 

MES(16) (1:30)=’. PRESS  RETURN  TO  CONTINUE’ 

MES (17) (1:30)=’ NO  ARCHIVE  FILES  FOUND’ 

MES (IB) (1:30)=' DATABASE  GONE’ 

MES (19) (1:30) -’PRESS  RETURN  TO  EXIT’ 

MES (20) (1:30)*’ NO  FILENAME* 

MES (21) (1:30) =’99  FILES  EXIST* 

MES (22) (1:30)=’ NO  PROCEDURE  FILES’ 

C  DISPLAY  THE  DESIRED  MESSAGE 

CALL  MENUDR (MES ( I ) (1 :L) , R, C, CL, 0, 1, 1) 

RETURN 

END 


t 


*******  **  •*  ••*•••*•*•»••  ***********  *»•*•»***< 

•••*«•«•«  «*«  **•  ••••••••»••»»  ••*••••*••••«  ••*•*••(•** 

1*  ««  ««««  ****  »•  *•  •»  •»  » 
I  «•  ••  •*  •*  *•  •*  «•  «•  1 


♦bi geode 

♦segment  '/teernseg 

SUBROUTINE  TCCM ( ITR, AUNIT, AFLAG, SUNIT1 , SUNIT2, SUNIT3, SUNIT4, 

*  CUNIT, CFILE, SFILE1 , SFILE2, SFILE3,  SFILE4, 

*  SMUNIT,  SMFILE,  MUNIT, MFILE) 

C************** ************************************* *************************** 
C  THIS  SUBROUTINE  MANAGES  THE  DATA  FOR  THE  TOXIC  CORRIDOR  CALCULATIONS. 

C  VARIABLES  PASSED: 

C 

C  ITR  -  INTERACTIVE  TERMINAL  READ  UNIT 

C  AUNIT  -  UNIT  #  ARCHIVE  FILE  IS  OPEN  ON 

C  AFLAG  -  FLAG  TO  INDICATE  WHETHER  IN  ARCHIVE  MODE 

C  TRUE  ==>  IN  ARCHIVE  MODE 

C  FALSE  ==>  NOT  IN  ARCHIVE  MODE 

C  SUNIT1  -  UNIT  #  TO  OPEN  SFILE1  ON 

C  SUN ITS  -  UNIT  #  TO  OPEN  SFILE2  ON 

C  SUNIT3  -  UNIT  #  TO  OPEN  SFILE3  ON 

C  SUNITA  -  UNIT  #  TO  OPEN  SFILEA  ON 

C  CUNIT  -  UNIT  #  TO  OPEN  CFILE  ON  (NOT  USED) 

C  CFILE  -  CLIMATOLOGICAL  DATABSE  FILE  NAME  (NOT  USED) 

C  SFILE1  -  SUBSTANCE  FILE  NAME 

C  SFILE2  -  SOURCE  FILE  NAME 

C  SFILE3  -  POINTER  FILE  NAME 

C  SFILEA  -  DATA  FILE  NAME 

C  SMUNIT  -  UNIT  #  TO  OPEN  MENU  FILE  (SMFILE)  ON 

C  SMFILE  -  MENU  FILE  NAME 

C  MUNIT  -  UNIT  #  TO  OPEN  MAP  FILES  ON 

C  MFILE  -  SUPER  DIRECTORY  FILE  FOR  MAPS 

C* ***************************** ************************************************ 

CHARACTER* 1  INP,CMD(1) 

CHARACTER*3  TT 

CHARACTER*8  DATES,  TEMP0, CC ( 1 0 ) 

CHARACTER*?  CFILE,  SFILE1 , SFILE2,  SFILE3,  SFILEA,  SMFILE,  MFILE 
CHARACTER*40  SKEY(2) 

CHARACTER*80  BK80 < 1 ) 

INTEGER  ITR,  I,  SUNIT1, SUNIT2,  SUNIT3, SUNITA, AUNIT, 

*  CUNIT,  RC(12,  3),  SMUNIT, ST(3>, ITT, EFLAG, MUNIT 

REAL  SDATA ( 1  A) , TDATA (2) , CDATA (A) 

LOGICAL  FLAG1 ,  FLAG2,  FLAG3,  FLAGA, AFLAG 

DATA  ST  /0, 0, 0/ 

DATA  TDATA/-I, -1/ 

BK80(1) (1:80)=’  ’ 

INP=’  ’ 

ITT=- 1  ' 

SKEY(l) (1 :A0)=’  * 

SKEY (2) (1:40)=’  ’ 

100  DO  1  1  =  1, 11,  1 

CC ( I ) (1:8)=*  » 

1  CONTINUE 

C  DISPLAY  THE  TCCM  MENU 

CALL  MENUSV (SMFILE,  300, RC,  12, SMUNIT) 
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C  DISPLAY  THE  SOURCE  OR  BLANK 
ST (3) =0 

CALL  MENUWR (RC, 1£, 2, 2, SKEY, 8, 1, ST) 

IF  THE  SOURCE  WAS  GIVEN  AS  A  ?  THEN  THE  USER  WAS  ALLOWED  TO 
CHOOSE  FROM  A  DISPLAYED  LIST.  WHEN  HE  HAS  MADE  HIS  CHOICE,  THE 
MAIN  MENU  IS  DISPLAY  ALONG  WITH  BOTH  CHOICES  AND  THE  USER  IS 
THEN  PLACED  AT  THE  SELECT  OPTION  LINE. 

IF  (INP  .EQ.  ’&’)  THEN 

CALL  MENUWR (RC, 12, 1, 1,  SKEY,  0, 1, ST) 

GOTO  105 

END  IF 


INPUT  THE  SUBSTANCE  AND  THE  SOURCE 

IST=1 

CALL  MENURD (RC, 12, 1ST, 2, SKEY, ITR) 

CHECK  TO  SEE  IF  THE  SUBSTANCE  AND/OR  THE  SOURCE  ARE  BLANK  OR  *. 

IF  EITHER  IS  THEN  GO  BACK  AND  GET  A  NON-BLANK  CHARACTER  STRING 

IF  ( (SKEY ( 1 )  .EQ.  »  * ).OR. (SKEY (2)  . EQ.  »  ’))  THEN 
IF  (SKEY (2)  .EQ.  »  ’>  IST=2 
IF  (SKEY ( 1 )  .EQ.  1  ’>  IST=1 
GOTO  5 

END  IF 

IF  ( (SKEY  ( 1 )  .EQ.  »#»  ).OR.  (SKEY  (2)  .  EQ.  *  **  )  )  THEN 
IF  (SKEY (2)  .EQ.  » *’ )  IST=2 
IF  ( SKEY ( 1 )  .EQ.  ’*’>  IST=1 
GOTO  5 

END  IF 


105 


DETERMINE  WHICH  COMMAND  THE  USER  HAS  SELECTED  AND  EXECUTE  THAT 
OPTION  PROVIDED  THAT  IT  IS  A  VALID  SELECTION. 

CMD(1)=*’  • 

CALL  MENURD(RC, 12, 11, 11,CMD, ITT) 


C  USER  WISHES  TO  GO  BACK  TO  THE  SUBSTANCE 
IF  (CMD(l)  .EQ.  ’  ’)  THEN 

IST=1 
ST (3) =1 

CALL  MENUWR  (RC,  12,  11,  11,CMD,0,  1,ST) 

CALL  MESS (4, RC ( 12, 1 ) , RC ( 12, 2) ,  RC (12,  3) ,  1 ) 
GOTO  5 
END  IF 

C  USER  WISHES  TO  USE  THE  MANUAL  MODE  OF  THE  TCCM 
IF  (CMD(l)  .EQ.  ’M’)  THEN 

INQUIRE  (FI LE*SF I LE 1 , EX I ST =FLAG 1 ) 

I NQU IRE  (FI LE=SF I LE2 , E X I ST =FLAG2 ) 

INQUIRE  (FILE*SFILE3, EXIST=FLAG3> 

INQUIRE  (FILE*SFILE4,EXIST=FLA64> 

IF  ((.NOT.  FLAGD.OR.  (.NOT.  FLA62) .  OR. 

*  (.NOT.  FLAG3K0R.  (.NOT.  FLAG4 > )  THEN 

CALL  MESS ( IS, RC ( 12, 1 ) , RC ( 12, 2) , RC ( 12, 3) , 6) 
GOTO  105 

END  IF 

CALL  TCCM1 (ITR, AUNIT, AFLAG, SUNIT1, SUNIT2, SUNIT3, 

*  SUNIT4, CUNIT, CFILE, SFILE1 , SFILE2, 

*  SFILE3, SFILE4,  SKEY, SMUNIT, SMFILE, 

*  MUNIT, MFILE) 
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GOTO  100 
END  IF 


C  USER  WISHES  TO  RETURN 

IF  (CMD  ( 1 )  .EQ.  ’X’)  RETURN 

C  INVALID  COMMAND 

IF  (CMD ( 1 )  .NE.  ’CM  GOTO  105 

PROCESS  THE  TCCM  DATA.  THIS  IS  THE  SECTION  OF  THE  CODE  THAT 
SEARCHES  THE  DATA  BASE  FOR  THE  DATA  THAT  IS  STORED  WITH  THE 
GIVEN  SUBSTANCE  AND  SOURCE.  WHEN  THE  SUBSTANCE  AND  THE  SOURCE 
ARE  SPECIFIED,  NO  MATTER  HOW  THAT  MAY  BE,  IT  WILL  EVENTUALLY  BE 
PROCESSED  THROUGH  THIS  SECTION  OF  CODE. 

IF  ( (SKEY  ( 1 )  .NE.  ’?’). AND. (SKEY (£)  .  NE.  ’  ?M  >  THEN 
EFLAG=0 
INP=’ &’ 

C  SEARCH  THE  SUBSTANCE-SOURCE  DATABASE  FOR  THE  DESIRED  ENTRY 

CALL  SSEAR (EFLAG,  ITR,  SUNIT1,  SUNIT2, SUNIT3, SUNIT4, INP, SKEY, 

*  SDATA,  SFILE1, SFILE2, SFILE3, SFILE4, SMUNIT, SMFILE) 

C  EFLAG  =  0  INNDICATES  THAT  THE  VALUES  WERE  FOUND  IN  THE  DATA  BASE: 

IF  (EFLAG  .EQ.  0)  THEN 

C  CONVERT  THE  REAL  DATA  TO  ALPHA  DATA 

CALL  MESS (4,  RC(12,  1 ) ,  RC  ( 12,  2) ,  RC  <  12,  3) , 1) 

WRITE(CC(3) (1:8), 25)  SDATA (2) 

WR I TE ( CC (4) (1:8), 25 )  SDATA (3) 

WRITE (CC (5) (1:8) ,25)  SDATA (4) 

WRITE (CC (6) (1:8), £5)  SDATA (11) 

25  FORMAT (FQ. 3) 

C  DISPLAY  THE  SUBSTANCE-SOURCE  DATA 

ST (3) =0 

CALL  MENUWR (RC,  12,  1 , 2,  SKEY,  0, 7, ST) 

CALL  MENUWR (RC, 12, 3, 6, CC, 0, 7, ST) 

CALL  MENUDR ( BK80, £3, 1 , 1 , 0, 1 , 1 ) 

RC ( 1 1,  2) =30 

CALL  MENUDR  (’C(ONTINUE)  OR  X  (RETURN)  ==>’,23,1,1,0,1,1) 

C  THIS  IS  WHERE  THE  I/O  DIRVERS  WILL  INPUT  THE  TEMPERATURE  DATA 

DO  169  K=l,  10,  1 
CC (K) (1:8)=’  ’ 

169  CONTINUE 

C  INPUT  TEMPERATURE  DATA 

IST=7 

170  CALL  MENURD(RC, 12, 1ST, 10, CC, ITR) 

C  INPUT  THE  USER  SELECTION 

171  CMD ( 1 >  =’  ' 

CALL  MENURD(RC, 12, 11, 11, CMD, ITT) 

C  USERS  WISHES  TO  RETURN 

IF  (CMD ( 1 )  .EQ.  ’X’)  RETURN 

C  USER  WISHES  TO  GO  BACK  TO  THE  SOURCE  STRENGTH 

IF  (CMD ( 1 )  .EQ.  ’  ’)  THEN 

IST=7 
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ST (3) =1 

CALL  MENUWR (RC,  12,  11,  11,CMD,0,  1,ST> 

CALL  MESS (4, RC(12, 1 ) ,  RC ( 12,  2) ,  RC ( 12,  3) ,  1) 
SOTO  170 
END  IF 

C  USER  SELECTED  INVALID  INPUT 

IF  (CMD(l)  .NE.  ’CM  GOTO  171 

C  CHECK  FOR  VALID  CL I MO  INPUT 

DO  168  K=l,4,  1 
CC (K) =CC (K+6) 

168  CONTINUE 

CALL  MENUCK (CC, CDATA, 4, ’ F8. 3’ , IERR) 

C  INVALID  CLIMO  DATA  ENTERED 

IF  (IERR  .NE.  0)  THEN 

ST (3) =1 
IST=IERR+6 
CMD(1>='  » 

CALL  MENUWR (RC, 12, 11, il,CMD, 0, 1,ST> 

CALL  MESS ( 1, RC ( 12, 1 ) , RC ( 12,  2) ,  RC ( 12,  3) , 6) 
GOTO  170 
END  IF 

PROCESS  AND  DISPLAY  THE  DATA 

CALL  TCCM2 ( ITR, AUNIT, AFLAG, SKEY, SDATA, CDATA, TDATA, 

SMUNIT,  SMFILE,  MUNIT, MFILE) 

INP»’  ’ 

GOTO  100 

END  IF 


EFLAG  »  10  INDICATES  THAT  ONE  OF  THE  4  REQUIRED  FILES  FOR  THE 
SUBSTANCE-SOURCE  DATA  BASE  WAS  NOT  FOUND. 

EFLAG  *  11  INDICATES  THAT  THE  SPECIFIED  SUBSTANCE  WAS  NOT  FOUND. 
ANY  OTHER  EFLAG  INDICATES  THAT  THE  SPECIFIED  SOURCE  WAS  NOT  FOUND. 
IF  (EFLAG  .EQ.  10)  THEN 

CALL  MESS (18, RC(12, 1 ) , RC ( 12, 2) , RC ( 12, 3) , 6) 

GOTO  105 
END  IF 

IF  (EFLAG  .EQ.  11)  THEN 

IST=1 
ELSE 
IST-2 
END  IF 

ST (3) *1 
CMD ( 1 ) ’ 

CALL  MENUWR  (RC,  12,  11,  11,CMD,0,  1,ST) 

CALL  MESS  (5,  RC(12,  1 ) ,  RC  ( 12,  2) ,  RC  ( 12,  3) ,  6) 

GOTO  5 

END  IF 

C  ALLOW  THE  USER  TO  SEARCH  THE  DAXA  BASE  '  - 
FLAG2-. FALSE. 

IF  (SKEY ( 1 )  .EQ.  *?’)  THEN 
FLAG2-. TRUE. 

INQUIRE  (FI LE-SF I LE 1 ,  EX I ST-FL AG 1 > 

IF  (.NOT.  FLAG1)  THEN 


C 

180 

* 
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COLL  MESS ( 18, RC ( 12, 1 ) , RC (12, 2) , RC ( 12, 3) , 8) 
GOTO  105 
END  IF 


C  COLL  ROUTINE  TO  DISPLAY  0  LIST  OF  THE  POSSIBLE  SUBSTANCES 

COLL  SBOST (SKEY, SUNIT1, SUNIT2, SFILE1, SFILE2,  SMUNIT, SMFILE, 
*  ITR, EFLAG) 


C 


NO  SUBSTANCE  WAS  FOUND  THAT  MATCHED  TO  BE  DISPLAYED 
IF  (EFLAG  .NE.  0)  THEN 

ST (3) =1 
CMD ( 1 )  =  '  * 

CALL  MENUWR (RC, 12, 11, 11, CMD, 0, 1,ST> 

COLL  MESS (5, RC(12, 1), RC<12,2),  RC(12,  3)  ,6) 

IST=2 

GOTO  5 

END  IF 

INP=’ &’ 


END  IF 

t 


C  USER  INPUT  A  ?  FOR  THE  SOURCE 
IF  (SKEY (2)  .NE.  ’ ?* )  GOTO  100 


ROUTINE  TO  DISPLAY  A  LIST  OF  THE  SOURCES  THAT  ARE  POSSIBLE  TO 
CHOOSE  FORM 

CALL  SRCQST ( SKEY,  SUN I T 1 ,  SUN I T2,  SF I LE 1 , SF I LE2, SMUN I T, SMF I LE, 

*  ITR, EFLAG) 

NO  SOURCES  WERE  FOUND  THAT  MATCHED  TO  BE  DISPLAYED 
IF  (EFLOG  .NE.  0)  THEN 

ST (3) =1 
CMD  ( 1 )  =’  ’ 

CALL  MENUWR (RC, 12, 11, 11, CMD, 0, 1,ST> 

CALL  MESS (5,  RC(12, 1 ) ,  RC ( 12, 2) ,  RC ( 12, 3) , 6) 

IST=1 

GOTO  5 

END  IF 

INP=’ &» 

GOTO  100 


END 

SUBROUTINE  TCCM1 ( ITR,  AUNIT,  AFLAG, SUNIT1, SUNIT2, SUNIT3, SUNIT4, 

*  CUNIT,  CFILE,  SFILE1, SFILE2, SFILE3, SFILE4, SKEY, 

*  SMUNIT, SMFILE,  MUNIT,MFILE) 


****************************************************************************** 
THIS  SUBROUTINE  ALLOWS  THE  USER  TO  MANUALLY  ENTER  10,30,60  MIN  SPEL’ S  AND 
SOURCE  STRENGTH  AND  Z  FACTORS  AND  SPILL  AREAS  AND  TEMPERATURES 
VARIABLES  PASSED: 


SOME  OS  FOR  TCCM 

C****************************************************************************** 


CHARACTER* 1  INP,CMD(1> 

CH0R0CTER*8  CC(14),EC(4) 

CHARACTER*?  CFILE,  SFILE1 ,  SFILE2,  SFILE3, SFILE4, SMFILE, MFILE 
CHARACTER*40  SKEY (2) 


INTEGER  ITR,  I,  EFLAG,  SUNIT1,  SUNIT2,  SUNIT3,  SMUNIT,  ST (3) , 

*  SUNIT4, AUNIT, CUNIT, RC(16,3>, ITT, MUNIT 
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REAL 

REAL 


CDATA (4)  |  TDATA (£> , TEMP (4) 
SDATA(IA) 


LOGICAL  AFLAC 

DATA  ST/0,0,0/ 

ITT=-1 

DO  5  1-1,14,1 
SDATA(I)-  0.0 
CC ( I)  (1:8)*'  ’ 

S  CONTINUE 

CHECK  TO  SEE  IF  THE  SUBSTANCE  IS  IN  THE  DATA  BASE  ,  IF  IT  IS 
THEN  THE  GMW  AND  10,30,  AND  60  MIN  PEL  EXIST. 

INP—’ 4* 

EFLAG-0 

SEARCH  THE  SUBSTANCE-SOURCE  DATA  BASE  FOR  A  MATCH 
CALL  SSEAR (EFLAG,  ITR,  SUNIT1,  SUNIT2,  SUNIT3,  SUNIT4, INP, SKEY, 

*  SDATA, SFILE1, SFILE2, SFILE3, SFILE4, SMUNIT, SMFILE) 

IF  EFLAG  -  11  THEN  THE  SUBSTANCE  WAS  NOT  FOUND  IN  THE  DATABASE. 

IF  (EFLAG  .NE.  11)  THEN 

SUBSTANCE  WAS  FOUND  IN  THE  1DATA  BASE 

DISPLAY  THE  MENU  AND  THE  DATA  RETRIEVED  FROM  THE  DATABASE 
CALL  MENUSV (SMFILE,  1 10,  RC,  16,  SMUNIT) 

ST (3) =0 

CALL  MENUWR  (RC,  16,  1,2,  SKEY,  0,  1,ST> 

WRITE(CC(3) (1:8),’  (Ffl, 3) * )  SDATA (2) 

WRITE (CC (4) (1:8), ’ (F0. 3) ■ )  SDATA(3> 

WRITE (CC (5) (1:6), *  (F0.3)’  )  SDATA (4) 

CALL  MENUWR  (RC,  16,3,5,  CC,  0,  1,  ST) 

EFLAG- 12  ==)  SOURCE  NOT  FOUND  AND  NO  SOURCE  STRENGTH  AVAILABLE 

IF  (EFLAG  .NE.  12)  WRITE (CC (6) ( 1 :8> ,  *  (F8. 3) ' )  SDATA(ll) 

INPUT  THE  SOURCE  STRENGTH  FROM  THE  USER 
CALL  MENURD (RC,  16, 6, 6, CC, ITR) 

IF  (CC (6)  .EQ.  ’  ’)  GOTO  125 

CONVERT  THE  CHARATCER  DATA  TO  REAL  DATA 
EC ( 1 ) -CC (6) 

CALL  MENUCK(EC, TEMP, 1, ’  (F8. 3) * , IERR) 

SINCE  NO  ERROR  OCCURRED  IN  THE  CONVERSION  ==>  THE  USER  IS  NOT  GOING 
TO  USE  THE  Z  FACTOR  METHOD 
IF  (IERR  .EQ.  0)  THEN 

SDATA (11) -TEMP ( 1 ) 

TDATA  (D  — 1 
TDATA  (2)  —1 
CC (7) (1:8)=’  ’ 

CC (8) (1:8)=’  ’ 

CC (9) (1:8)-*  ’ 

ST  (3) =0 

CALL  MENUWR  (RC,  16,  7,9,  CC,0,  1,  ST) 

IST-10 
GOTO  170 
END  IF 


C  USER  IS  GOING  TO  USE  THE  Z  FACTOR  METHOD  ==>  ZFACTOR  AND  SPILL  AREA 

C  AND  SPILL  TEMPERATURE  TO  BE  INPUT 

CC(6)(1:8)=»  ’ 

WRITE  <CC (7)  ( 1 : 8) , ’  (F8. 3) * )  S DATA (5) 

ST (3) =0 

C  DISPLAY  THE  Z  FACTOR  STORED  IN  THE  DATABASE 

CALL  MENUWR  <RC, 16, 6, 7, CC, 0, 1, ST) 

SDATA ( 1 1)=— 1. 0 

C  INPUT  THE  SPILL  PARAMETERS 

IST=7 

130  CALL  MENURD (RC, 16, 1ST, 9, CC, ITR) 

C  INPUT  THE  TEMPERATURE  DATA 

IST=10 

170  CALL  MENURD (RC,  16,  1ST, 13, CC, ITR) 

C  SCANNING  THE  COMMAND' INPUT  LINE 

160  CMD ( 1 )  =’  » 

CALL  MENURD (RC,  16,  14, 14, CMD, ITT) 

C  USER  SELECTED  TO  RETURN 

IF  (CMD  ( 1 )  .EQ.  ’X’>  RETURN 

C  USER  SELECTED  TO  GO  BACK  TO  THE  SOURCE  STRENGTH  INPUT  LINE 

IF  (CMD ( 1 )  .EQ.  »  ’)  THEN 

ST (3) =1 

CALL  MESS (4, RC ( 15, 1 ) , RC ( 15,  2) ,  RC ( 15,  3) ,  1 ) 

CALL  MENUWR (RC, 16, 14, 14, CMD, 0, 1, ST) 

GOTO  125 
END  IF 

C  INVALID  INPUT 

IF  (CMD ( 1 )  .NE.  ’CM  GOTO  160 

C  CHECK  THE  SOURCE  STRENGTH  OR  Z  FACTOR  DATA  TO  BE  VALID 

IF  (SDATA (11)  .NE.  -1.)  THEN 
IF  (SDATA (11)  .LE.  0)  THEN 
CMD  ( 1 )  =’  » 

ST (3) =1 

CALL  MENUWR (RC, 16, 14, 14, CMD, 0, 1, ST) 

;  CALL  MESS ( 1, RC ( 15, 1 ) , RC ( 15, 2) , RC ( 15, 3) , 7) 

GOTO  125 

END  IF 
ELSE 

C  CONVERT  THE  CHARACTER  DATA  TO  REAL  DATA 

EC ( 1 ) *CC (7) 

EC  (2)  =CC  (8) 

EC (3) =CC (9) 

CALL  MENUCMEC,  TEMP,  3,  ’F(8.  3)*,  IERR) 

C  ERROR  OCCURRED  IN  THE  CONVERSION  PROCESS 

IF  (IERR  .NE.  0)  THEN 

CMD  ( 1 )  *’  ’ 

ST (3) =1 

CALL  MENUWR ( RC, 1 6, 1 4, 1 4, CMD, 0, 1 , ST ) 

CALL  MESSU,  RC(15,  1 ) ,  RC  ( 15,  2) ,  RC ( 15,  3) ,  7) 
IST-IERR+6 
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GOTO  130 
END  IF 

DO  180  K-l,  3,  1 

IF  (TEMP (K)  .LE.  0)  THEN 
CMD ( 1 )  =’  » 

ST (3) =1 

CALL  MENUWR(RC, 16, 14, 14, CMD, 0, 1,ST> 

CALL  MESS ( 1 ,  RC ( 15, 1  > ,  RC  ( 15,  £> ,  RC  ( 15,  3) ,  7> 

IST=K+6 

GOTO  130 

END  IF 

CONTINUE 


C  PLACE  Z  FACTOR  DATA  INTO  THE  PROPER  PLACES 

SDATA (5) =TEMP ( 1 ) 

TDATA ( 1 ) =TEMP (2) 

TDATA (2) =TEMP (3) 

END  IF 

C  CHECK  FOR  VALID  CL I MO  INPUT 

DO  175  1-1,4,  1 
EC ( I ) =CC ( 1+9) 

175  CONTINUE 

CALL  MENUCK (EC, CDATA, 4, ’  (F8.  3) * , IERR) 

C  ERROR  OCCURRED  IN  THE  CONVERSION  PROCESS 

IF  (IERR  .NE.  0)  THEN 

CMD  ( 1 )  =**  » 

ST (3) =1 

CALL  MENUWR ( RC, 16, 14, 14, CMD,  0, 1,ST> 

CALL  MESS ( 1, RC ( 15, 1 > , RC ( 15, £) , RC( 15,  3) ,  7) 

IST-IERR+9 

GOTO  170 

END  IF 

ELSE 

C  THE  SUBSTANCE  IS  NOT  IN  THE  DM3V  BASE 

C  DISPLAY  THE  MENU  AND  THE  SUBSTANCE  AND  THE  SOURCE 

CALL  MENUSV(SMFILE,  111,  RC,  16, SMUNIT) 

ST (3) =0 

CALL  MENUWR (RC, 16, 1,2, SKEY, 0, 1,ST> 

C  INPUT  THE  10,30,  AND  60  MIN  SPELS 

IST=3 

£20  CALL  MENURD(RC, 16,  1ST,  6, CC,  ITR) 

C  INPUT  THE  SOURCE  STRENGTH 

225  CALL  MENURD(RC, 16, 7,  7,  CC, ITR) 

IF  (CC (7)  .EQ.  ’  ’>  GOTO  225 

C  CONVERT  THE  CHARACTER  DATA  TO  REAL  DATA 

EC ( 1 ) =CC (7) 

CALL  MENUCK (EC, TEMP, 1 , ’  (F8.  3) » ,  IERR) 


C  IF  NO  ERROR  OCCURRED  ==>  USER  WILL  NOT  USE  Z  FACTOR  METHOD 

IF  (IERR  .EQ.  0)  THEN 

SDATA (11) =TEMP ( 1 ) 

SDATA (5) =0. 

TDATA (1>=-1 
TDATA  (2>— 1 


. 
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CC  (8)  (1:8)=*  ’ 

CC(9>  (1:8)=’  ’ 

CC<10) <1 :8>=’  ’ 

ST (3) =0 

CALL  MENUWR  ( RC,  18,8,  10,  CC,  0,  1,ST) 
IST=1 1 
GOTO  270 
END  IF 

USER  WILL  USE  THE  Z  FACTOR  METHOD 
CC (7) (1:8)=’  ’ 

ST (3) =0 

CALL  MENUWR (RC, 16,7, 7, CC,  0,  1,  ST) 

SDATA ( 1 1 ) =-l. 0 

INPUT  THE  Z  FACTOR  AND  SPILL  PARAMETERS 
IST=8 

CALL  MENURD(RC, 16, 1ST, 10,  CC, ITR) 

t 

INPUT  THE  TEMPERATURE  DATA 
I ST= 1 1 

CALL  MENURD(RC,  16, 1ST, 14, CC, ITR) 

SCANNING  THE  COMMAND  INPUT  LINE 
CMD ( 1 ) =’  ’ 

CALL  MENURD (RC, 16, 15, 15,  CMD, ITT) 

USER  SELECTED  TO  RETURN 
IF  (CMD  ( 1 )  .  EQ.  ’X’)  RETURN 


USER  SELECTED  TO  GO  BACK  TO  THE  GMW,  10,  30,  60  SPEL  LINES 
IF  (CMD ( 1 )  .EQ.  ’  ’)  THEN 

ST (3) =1 

CALL  MESS (4, RC ( 16, 1 ) , RC ( 16, 2) , RC ( 16, 3) , 1) 
CALL  MENUWR (RC, 16, 15, 15, CMD, 0, 1,ST) 

IST=3 
GOTO  220 
END  IF 

INVALID  COMMAND 

IF  (CMD ( 1 )  .NE.  ’C’>  GOTO  £60 

CHECK  THE  GMW,  10,  30  AND  60  MIN  PEL’S 
EC ( 1 ) =CC (3) 

EC  (2)  =CC  (4) 

EC  (3)  =CC  (5) 

EC  (4)  =CC  (6) 

CALL  MENUCK (EC, TEMP, 4, ’ (F8. 3) * , IERR) 

ERROR  IN  THE  CONVERSION  PROCESS 
IF  (IERR  .NE.  0)  THEN 

CMD  <  1 )  ='  ’ 

ST (3) =1 

CALL  MENUWR  ( RC,  16,  15,  15,  CMD,  0,  i,5T) 

CALL  MESS  ( 1 ,  RC  <  16,  1 ) ,  RC  <  16,  2) ,  RC  <  16,  3> ,  7) 
IST=lERR+£ 

GOTO  £20 
END  IF 

DO  £85  K-1,4,  1 

IF  (TEMP (K)  .LE.  0)  THEN 


CMD ( 1 )  =’  ’ 

ST<3>»1 

CALL  MENUWR ( RC, 16, 15, 15,  CMD,  0,  1,ST> 

CALL  MESS ( 1 , RC(16, 1), RC(16,2> , RC(16, 3) , 7) 

IST-K+2 

SOTO  220 

END  IF 

SDATA (K) =TEMP (K) 

285  CONTINUE 


C  CHECK  THE  SOURCE  STRENGTH  AND  Z  FACTOR 

IF  (SDATA (11)  .NE.  -1.)  THEN 
IF  (SDATA (11)  .LE.  0)  THEN 
CMD ( 1 ) =’  ’ 

ST (3) =1 

CALL  MENUWR (RC, 16, 15,  15, CMD, 0,  1,ST) 

CALL  MESS ( 1, RC ( 16, 1 ) , RC ( 16, 2) , RC ( 16, 3) , 7) 
GOTO  225 

END  IF 
ELSE 

EC ( 1 ) =CC (8) 

EC (2) =CC (9) 

EC (3) =CC (10) 

CALL  MENUCK (EC,  TEMP,  3,  ’  F  (8.  3)  ’  , IERR) 


C 


280 


ERROR  IN  THE  CONVERSION  PROCESS 
IF  (IERR  .NE.  0)  THEN 

CMD ( 1 ) =’  * 

ST (3) =1 

CALL  MENUWR (RC, 16, 15, 15, CMD, 0, 1,ST> 

CALL  MESS ( 1 , RC ( 16, 1 > , RC ( 16, 2> , RC ( 16,  3) ,  7) 

IST-IERR+7 

GOTO  230 

END  IF 

DO  280  K=l,  3, 1 

IF  (TEMP (K)  .LE.  0)  THEN 
CMD ( 1 ) =’  * 

ST (3) =1 

CALL  MENUWR (RC, 16, 15, 15, CMD, 0, 1,ST> 

CALL  MESS  ( 1 ,  RC  ( 16,  1),  RC  ( 16,  2) ,  RC  ( 16,  3) ,  7) 

IST-K+7 
GOTO  230 

END  IF 

CONTINUE 


C  PLACE  Z  FACTOR  DATA  INTO  THE  PROPER  PLACES 

SDATA (5) -TEMP ( 1 ) 

TDATA ( 1 ) =TEMP (2) 

TDATA (2) -TEMP (3) 

END  IF 

C  CHECK  FOR  VALID  CL I MO  INPUT 

DO  275  1-1,4,  1 
EC ( I > -CC (1+10) 

275  CONTINUE 

CALL  MENUCK (EC, CDATA, 4, »  (F8. 3) * , IERR) 


C  ERROR  IN  CONVERSION  PROCESS 

IF  (IERR  .NE.  0)  THEN 

CMD ( 1 ) — ’  • 
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ST  <3) =1 

CALL  MENUWR  ( RC,  16,  15,  15,CMD,®,  1,ST) 

CALL  MESS ( 1, RC ( 16, 1 ) , RC ( 16, 2) ,  RC ( 16,  3) ,  7) 
IST=IERR+1® 

GOTO  27® 

END  IF 
END  IF 

C  MAKE  THE  TOXIC  CORRIDOR  CALCULATION 

CALL  TCCM2 ( ITR, AUNIT,  AFLAG,  SKEY, SDATA, CDATA, TDATA, SMUNIT, SMFILE, 
*  MUNIT, MFILE) 

RETURN 
END 

SUBROUTINE  TCCM2 (ITR,  AUNIT,  AFLAG,  SKEY, SDATA, CDATA, TDATA, 

SMUNIT, SMFILE, MUNIT,  MFILE) 

ARGUMENT  VARIABLE  TYPES 

INTEGER  ITR, AUNIT, SMUNIT, MUNIT 

REAL  SDATA  < 1 ) ,  CDATA ( 1 ) ,  TDATA ( 1 ) 

CHARACTER*40  SKEY ( 1 ) 

CHARACTER*7  SMFILE, MFILE 
LOGICAL  AFLAG 

PROGRAM  VARIABLE  TYPES 

REAL  PF,  Q,  GMW,  PEL (3),  WINDS, 

CORWID,  DELTAT,  SIGTH,  DIST(3,2) 

EXTERNAL  FUNCTIONS 

REAL  OCEANT 


INITIALIZE  ARRAYS  AND  VARIABLES 

DO  1®  1-1,3,  1 
PEL  ( I )  *  -1.® 

IF  (SDATA (1+1)  .GT.  0.0)  PEL(I>=  SDATA (1+1) 

DO  20  J=l, 2, 1 

DIST ( I,  J) *  -1.0 
CONTINUE 
CONTINUE 

COMPUTE  CORRIDOR  BASED  ON  A  90*  PROBABILITY  LEVEL (PL) :  FACTOR(PF>=  1.63 
PF=  1.63 

DEFINE  VARIABLES 

GMW3  SDATA ( 1 ) 

WINDS*  CDATA (1) 

SIGTH*  CDATA (3) 

DELTAT*  CDATA (4) 

Q=  SDATA (11) 

IF  CN-1,  THE  SOURCE  STRENGTH  MUST  BE  COMPUTED  VIA  THE  SPILL  EQUATION 

IF (  Q.EQ. -1.  )  THEN 
A*  TDATA ( 1 ) 

TP*  TDATA (2) 

Z*  SDATA (5) 

Q=  1.66E-04  *  (WINDS**. 75)  *  A 
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.  *  (  1.0  +  (  4. 3E-03  *(TP**2.0>  >  >  *  Z 

SDATA (11)=  -Q 
END  IF 

COMPUT  CORRIDOR  LENGTHS 


DO  30  1  =  1,3,  1 
IF  <  PEL ( I  > 


CONTINUE 


.GT.  0.)  THEN 

DISTII, 1)=  OCEANT (PF, GMW, PEL (I) , Q, DELTAT) 
IF (  SIGTH  .GT.  0.0  )  THEN 

DIST ( I , 2) =  OCEANS (PF, GMW, PEL ( I ) , Q, 

SIGTH, DELTAT) 

END  IF 

END  IF 


COMPUTE  CORRIDOR  WIDTHS 


IF  {WINDS- LE- 3.0}  THEN  C0RWID=  3b0-0 

60  TO  35 

IF  {SIGTH- 6T. 0.0}  THEN  C0RWID=  b-0  *  SIGTH 

GO  TO  35 

IF  {WINDS- GT. 10.0}  THEN  C0RWID=  b0-0 
ELSE  C0RWID=  10.0 


ENDIF 

5  CONTINUE 


CALL  TCDISP (  ITR,  AUNIT,  AFLAG,  SKEY, SDATA, CDATA, TDATA, 
CORWID, DIST, SMUNIT, SMFILE, MUNIT, MFILE) 


RETURN 
END 

REAL  FUNCTION  OCEANT (PF, GMW, GLC, Q, DELTAT) 

COMPUTE  CORRIDOR  LENGTH  BASED  ON  THE  DELTA-T  VERSION  OF  THE  OCEAN 
BREEZE/DRY  GULCH  EQUATION 

REAL  PF,  GMW,  GLC,  Q,  DELTAT 

CHECK  FOR  VALID  INPUT 

IF (  (GMW  .LE.  0.)  .OR.  (Q.  LE.  0.  )  .OR.  (PF.LE.0.  >  >  RETURN 

OCEANT*  PF*  (  3.28 

.  *( (29.  75/GMW) **0.513) 

.  *( (GLC/Q)**(-0. 513) > 

.  * ( (DELTAT+10) **2. 53)  ) 

RETURN 
END 

REAL  FUNCTION  OCEANS (PF,  GMW,  GLC, Q, SIGTH, DELTAT) 

COMPUTE  CORRIDOR  LENGTH  BASED  ON  THE  SIGMA  THETA  VERSION  OF  THE  OCEAN 
BREEZE/DRY  GULCH  EQUATION 

REAL  PF, GMW, GLC, Q, SIGTH, DELTAT 
C 

C  CHECK  FOR  VALID  INPUT 
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C 

IF  <  (GMW  .LE.  0.)  .OR.  (Q.  LE.  0.  )  .OR.  CPF.LE.0.  )  >  RETURN 
C 

OCEANS=  PF*  (  3.28 

*( (357. 0/GMW) **0.510) 

*( <GLC/Q)**(-0  510) ) 

*<SIGTH**<-0. 258) ) 

.  *( (DELTAT+10) **2.208)  ) 

C 

RETURN 

END 

SUBROUTINE  TCDISP (ITR,  AUNIT,  AFLAG,  SKEY, SDATA, CDATA, TDATA, 

CORWID, DIST, SMUNIT, SMFILE,  MUNIT,  MFILE) 

INTEGER  AUNIT,  ITR,  SMUNIT,  RC (30,  3) ,  S ( 10) ,  ROW,  COL,  MUNIT 

REAL  SDATA ( 1 ) , CDATA ( 1 ) ,  TDATA ( 1 ) , PL, CORWID, DIST (3, 2) , TCP (6) 


CHARACTER*40 

CHARACTER*15 

CHARACTER*? 

CHARACTER*! 


SKEY ( 1 ) , D I SP ( 30 ) 
STAMP, STAMPS (2) 
SMFILE, MFILE 
INP( 1 ) , FORMFD 


LOGICAL  AFLAG 


C 


DATA  S/  10*0  / 
S  (2)  =>  SMUNIT 


INITIALIZE  THE  DISPLAY  TEXT  ARRAY 
DO  1  1  =  1,30 

WRITE (DISP ( I ) (1:40),’ (40X)’  ) 
CONTINUE 

INITIALIZE  THE  FILE  STORAGE  SYSTEM 
CALL  MENUDRC  *  ,  1 ,  1 , 0, -1 , 0,  0) 


PROCESS  MENU  ID=£50 

CALL  MENUSV (SMFILE, £50, RC, 30, SMUNIT) 


CALL  TIME (STAMP) 

DISP ( 1 ) (Is  15)  =  STAMP ( 1 : 15) 

STAMPS  ( 1 )  «*  STAMP 
CALL  DATE (STAMP) 

DISP  (2)  (.1  :  15)  ■  STAMP  (1:15) 

STAMPS (2) =  STAMP 

DISP(3> (1 s40)=  SKEY(l) (1:40) 

DISP(4) (1:40)=  SKEY(2) (1:40) 

Q=  ABS  (SDATA  (ID) 

WRITE(DISP(5) (1:9),’ (F9.2)’ )  Q 

WRITE (DISP (6) (1:5),' (F5. 1)' )  CDATA(l) 
WRITE (DISP (7) (1:5),’ (F5. 1)’ )  CDATA (2) 
WRITE (DISP (8) (1:5),’ (F5. 1)’ )  CDATA (3) 
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WRITE (DISP (9) (1:5),’  (F5. 1)’ )  CDATA(4> 

C 

DCOR-  CDATA (2) +180. 

IF (  DCOR. GT. 360.  )  DCOR*  DCOR-380. 

WRITE (DISP (10) (ls5), ’ (F5. 1 )  ’  )  DCOR 
WRITE (DISP (11) (1:5),’ (F5. 1)’ )  CORWID 
C 

IF (  CDATA (3)  .GT.  0.0  )  THEN 

WRITE(DISP(18)  (1:19),’  (”OB/DB  (SIGMA  THETA)  ”)  *  ) 
END  IF 

DO  20  1*1,3,  1 
ID1*  1+11 
ID2*  1+18 
ID3*  1+14 

WRITE(DISP(ID1) (1:8)  , ’ (F8. 1 ) ’  )  SDATA(I+1) 

IF (  CDATA(3)  .GT.  0.0  )  THEN 

WRITE (DISP (ID2) ( 1 : 1 1 ) , ’ (FI 1. 1 ) * )  DIST(I,2) 

END  IF 

WRITE (DISP (ID3) ( 1 : 1 1 ) , ’  (FI 1 . 1 ) *  >  DIST (1,1) 

20  CONTINUE 


IF  THE  SOURCE  STRENGTH  WAS  CALCULATED  VIA  THE  SPILL  EOUATION,  SHOW  DATA 

IF (  SDATA (11). LT. 0. 0  )  THEN 

WRITE (DISP (22) (1:10),'  (’’SPILL  DATA’ ’ )’ > 

WRITE (DISP (23) (1:29),*  (”  POOL  AREA  (SQ  FT) :  ' ’ , F9. 1 ) ' ) TDATA ( 1 ) 

WRITE (DISP (24) (1:29),'  (’’POOL  TEMP. ...  (C) :  ”  , F9. 1) ’ ) TDATA (2) 

WRITE  (DISP  (25)  (1:29), ’(”  Z  FACTOR .  ”  ,  F9.  3)  ’  )  SDATA  (5) 

END  IF 
C 

CALL  MENUWR ( RC,  30,  1, 25,  DISP,  0,  0, S) 

C  IF  THE  ARCHIVE  MODE  IS  ACTIVE,  WRITE  THE  DISPLAY  TO  THE  ARCHIVE  FILE 
IF  (AFLAG)  CALL  MENUDR(’  ’  ,  1 ,  1,  0, -2,  AUNIT,  0) 

C  PROCESS  THE  COMMAND  LINE 

40  INP ( 1 ) *’  » 

CALL  MENURD (RC, 30, 30, 30, INP, -1 ) 

C  USER  WANTS  TO  PRINT  THE  DISPLAY 

IF (  INP ( 1 )  .EQ.  'P'  )  THEN 

OPEN (15, FILE*’ /DEV/PRT’  ) 

IFORM-  12 

FORMFD*  CHAR (IFORM) 

WRITE (15, ’ (Al)*)  FORMFD 
CALL  MENUDR ('  ’ , 1, 1, 0, -2, 15, 0) 

WRITE (15, ’ (Al)’ )  FORMFD 
CLOSE (15) 

END  IF 

C  USER  WANTS  TO  PLOT  THE  TOXIC  CORRIDOR 

IF (  INP ( 1 )  .EQ.  ’G'  )  THEN 

TCP (1)*DIST(1,  1) 

TCP (2) ®DIST (2,  1) 

TCP (3) *DIST (3,  1) 

TCP (4) -CORWID 
TCP (5) *DCQR 

CALL  TCGRPHUTR,  SMUNIT,  SMFILE,  MUNIT,  MFILE,  TCP, 
STAMPS) 
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RETURN 
END  IF 


USER  WONTS  TO  RETURN  TO  THE  COLCULOTION  MENU 
IF <  INP(l)  .EQ.  ’X’  )  RETURN 

GO  TO  40 
END 
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♦BIGCODE 

♦SEGMENT  fcTCGRPH 

SUBROUTINE  TCGRPH  < ITR,  SMUNIT,  SMFILE, MUNIT, MFILE, TCP, STOMPS) 


C****************************************************************************** 


c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 


THIS  SUBROUTINE  PROCESSES  THE  MOP  DATA  AND  DRAWS  THE  MAPS  ON  THE  PLOTTER 
VARIABLES  PASSED: 


ITR 

SMUNIT 

SMFILE 

MUNIT 

MFILE 

TCP 


STAMPS 


INTERACTIVE  TERMINAL  READ  UNIT 

-  UNIT  #  TO  OPEN  MENU  FILE  (SMFILE) 

-  MENU  FILE  NAME 

-  UNIT  #  TO  OPEN  THE  MAP  FILES  ON 

-  MAP  HEADER  FILE  NAME  (SUPER  DIRECTORY  FILE) 

-  ARRAY  TO  HOLD  THE  TOXIC  CORRIDOR  PARAMATERS 
TCP  ( 1 )  - 

TCP (2)  - 
TCP (3)  - 

-  ARRAY  TO  HOLD  THE  TIME  AND  DATE  THE  CALCULATIONS  WERE  MODE 


FLAG1  -  USED  TO  DETERMINE  WHETHER  THE  PLOT  IS  ON  AN  OLD  OR  NEW  MOP 
FALSE  ==>  NEW  MAP 
TRUE  ==>  OLD  MAP 


C****************************************************************************** 


CHARACTER*48 

10, TT (2) 

CHOROCTER*40 

TEXT (£> , TEMI , IOP, FNAME 

CHOROCTER*20 

ANNO 

CHARACTER* 15 

STOMPS (2) 

CH0RACTER*7 

SMFILE, MFILE 

CHARACTER* 1 

CMD ( 1 ) , INP 

INTEGER 

ITR, SMUNIT, MUNIT, RC (4, 3), ST (3), HDR, IS, IE,WCS(3) 

ANGLE,  RECNO,  SN, ID, NPTS, EFLAG, MARKS (£0) , SYM 

REAL 

TCP (6) , FPI 

LOGICAL 

FLOG, FLOG 1,  FLAGS 

DATA  ST  /0,  0, 

0/ 

C  ’MARKS’  LINKS  THE  £0  TYPES  OF  MAP  INFORMATION  TO  HOUSTON  PLOTTER  SYMBOLS 
DATA  MARKS/  0,  2,  3,  0,  0,  0,  0,  4,  0,  0,  0,  0,  0,  0,  0,  5,  1, 0,  0,  0/ 

ITT*- 1 

FLAG1=. FOLSE. 

C  DISPLAY  THE  PLOT  OPTIONS  MENU 
£0  CALL  MENUSV (SMFILE, 301, RC, 4, SMUNIT) 

C  SCON  THE  COMMAND  INPUT  LINE 

25  CMD  ( 1 )  =»’  ’ 

COLL  MENURD(RC, 4, 1, 1,CMD, ITR) 

C  CHECK  FOR  VALID  INPUT 

IF  ( INDEX (’ 123X’ , CMD ( 1 ) )  . EQ.  0)  THEN 

CALL  MESS ( 11, RC (2, 1 ) , RC (2, 2) , RC (2, 3) , 7) 
GOTO  25 
END  IF 

C  THE  USER  SELECTED  TO  RETURN 

IF  (CMD ( 1 )  .EQ.  ’X’)  RETURN 

C  PLOT  ONLY  CORRIDOR 
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15 

C 

C 


c 

c 

1000 

c 


c 

100 

c 

150 

C 


IF  (CMD(l)  .  EQ.  ’1»>  THEN 

ST (3) =  1 
RC (3, 1 ) =£0 
RC(3,2>  =  1 
RC  (3,  3)  =33 

TT(1>=*  ENTER  SCALE  FACTOR  (FT/ INCH)  ==>  * 

CALL  MENUWR ( RC,  4, 3, 3, TT, 0, 7, ST) 

RC (4, 1)=£0 
RC (4,  2) =35 
RC(4, 3) =8 
TT(1) (1:48)=’  ’ 

CALL  MENURD(RC,4,  4,  4,  TT,  ITT) 

READ (TT ( 1 ) ( 1 : B) ,  ’  (F8. 0) * , ERR=15>  FPI 

PLOT  THE  CORRIDOR  USING  FPI  SCALE  FACTOR 
CALL  CORPLT(FPI, TCP, STAMPS) 

GOTO  20 
END  IF 

PLOT  CORRIDOR  ON  OLD  MAP 
IF  (CMD(l)  .EQ.  ’3’)  THEN 

FLAG1-.  TRUE. 

ST (3) =1 
RC (3,  1)=20 
RC (3, 2) =1 
RC (3,  3) =41 

TT(1)=» REGISTER  MAP  AND  PRESS  RETURN  TO  CONTINUE* 
CALL  MENUWR (RC, 4,3, 3, TT, 0, 7, ST) 

READdTR,  *  (Al)*  >  INP 
END  IF 

PLOT  CORRIDOR  ON  NEW  MAP 
INP=*  * 

TEXT(l) (1:40)=’  ’ 

TEXT (2) ( 1 :40) =’  ’ 

DISPLAY  THE  MENU  TO  INPUT  THE  BASE  AND  MAP  FILE  NAMES 
CALL  MENUSV ( SMF I LE,  251,  RC, 4, SMUNIT) 

CHECK  TO  SEE  IF  ?  WAS  USED 
IF  (INP  .EQ.  *#» )  THEN 

ST (3) =0 

CALL  MENUWR  ( RC,  4,1,2,  TEXT,  0,  1 ,  ST) 

GOTO  150 
END  IF 

INPUT  THE  BASE  AND  MAP  FILE  NAMES 
IST=1 

CALL  MENURD(RC, 4, 1ST, 2,  TEXT, ITR) 

SCAN  THE  COMMAND  INPUT  LINE 
CMD ( 1 ) =’  ’ 

CALL  MENURD ( RC, 4, 3, 3, CMD, ITT) 

THE  USER  WISHES  TO  GO  BACK  TO  THE  FIRST  BASE  MAP  FILE  NAME 
IF  (CMD ( 1 )  .EQ.  *  ’)  THEN 

ST (3) =1 

CALL  MESS <4, RC (4, 1 ) ,  RC (4,  2) ,  RC (4,  3) ,  1 ) 

CALL  MENUWR (RC, 4, 3, 3, CMD,  0, 1,  ST) 

IST-1 
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END  IF 

C  THE  USER  SELECTED  TO  RETURN  TO  THE  CORRIDOR  OPTIONS  MENU 
IF  (CMD(l)  .EQ.  ’XM  GOTO  20 

C  INVALID  INPUT 

IF  (CMD(l)  .NE.  ’CM  GOTO  150 

C  IF  THE  USER  SPECIFIED  A  ?  FOR  BASE  MAP  DISPLAY  LIST 
IF  (TEXT ( 1 )  .EQ.  ’?’)  THEN 

C  FIRST  CHECK  TO  SEE  IF  THE  SUPER  DIRECTORY  IS  AVAILABLE 

INQUIRE  (FILE=MFILE, EX IST=FLAG) 

C  IF  NOT  AVAILABLE  THEN  DISPLAY  AN  ERROR  MESSAGE  NOT  FOUND 

IF  (.NOT.  FLAG)  THEN 

ST (3) =1 
CMD ( 1 )  ='  ’ 

CALL ,MENUWR (RC,  4, 3, 3, CMD, 0, 1, ST) 

CALL  MESS (5, RC(4, 1 ) , RC (4, 2) , RC (4, 3) , 7) 

IST=1 
GOTO  100 
END  IF 

C  CALL  ROUTINE  TO  DISPLAY  THE  LIST  OF  BASE  MAPS  AVAILABLE 

FNAME=MF1LE 

CALL  MOST (TEXT ( 1 ) , MUNIT,  FNAME, SMUNIT, SMFILE, ITR, EFLAG, 

*  42,252) 

CHECK  THAT  NO  ERROR  OCCURRED  WHILE  TRYING  TO  DISPLAY  THE  LIST. 

I.E.  THERE  ARE  NO  ENTRIES  IN  THE  SUPER  DIRECTORY 
IF  (EFLAG  .NE.  0)  THEN 

ST (3) =1 
CMD ( 1 ) ='  ’ 

CALL  MENUWR  ( RC,  4,3,3,  CMD,  0,  1 ,  ST) 

CALL  MESS (5, RC (4, 1 ) , RC (4, 2) , RC (4, 3) , 7) 

IST=1 
GOTO  100 
END  IF 

INP=’ *’ 

IF  MAP  FILE  NAME  IS  KNOWN,  THEN  GO  BACK  AND  FILL  IN  THE  BASE  MAP 
FILE  NAME  IN  THE  MENU  AND  CONTINUE 
IF  (TEXT (2)  .NE.  ’ ?’ )  GOTO  1000 

END  IF 

C  CHECK  IF  THE  BASE  MAP  EXISTS  THAT  THE  USER  SPECIFIED  (PACKING  REQUIRED) 
TEMP=TEXT ( 1 ) 

CALL  PACK (TEMP, J) 

INQUIRE  .(FILE=TEMP, EX IST=FLAG) 

C  IF  BASE  MAP  FILE  DOES  NOT  EXIST,  THEN  DISPLAY  ERROR  MESSAGE 

IF  (.NOT.  FLAG)  THEN 

ST (3) = 1 
CMD  ( 1 )  =’  ’ 

CALL  MENUWR (RC, 4, 3, 3, CMD, 0, 1, ST) 

IST=1 

IF  (INP  .EQ.  ) 

*  CALL  MENUSV (SMFILE, 251, RC, 4, SMUNIT) 
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CALL  MESS  (5,  RC  <4,  1 ) ,  RC  (4,  £) ,  RC  (4,  3) ,  7) 

GOTO  100 
END  IF 

C  CHECK  FOR  A  ?  FOR  THE  MAP  FILE  NOME 
IF  (TEXT (2)  .EQ.  ’  ?’ )  THEN 

CALL  ROUTINE  TO  DISPLAY  A  LIST  OF  THE  MAP  FILES  CONTAINED  IN  THE 
SELECTED  BASE  MAP 

CALL  MOST (TEXT (2) ,  MUNIT,  TEMP,  SMUNIT,  SMFILE,  ITR,  EFLAG, 

*  50, 253) 

CHECK  THAT  NO  ERRORS  OCCURRED  WHILE  DISPLAYING  THE  LIST.  I.E. 

THAT  NO  ENTRIES  WERE  FOUND  IN  THE  BASE  MAP  FILE 
IF  (EFLAG  .NE.  0)  THEN 

ST (3) =1 
CMD ( 1 )  =’  ’ 

CALL  MENUWR (RC, 4, 3, 3, CMD, 0,  1,  ST) 

IST=2 

IF  ,( INP  .  EQ.  ’  *’  ) 

*  CALL  MENUSV (SMFILE, £51, RC, 4, SMUNIT) 

CALL  MESS (5,  RC (4,  1 ) , RC (4, 2) , RC (4, 3) , 7) 

GOTO  100 
END  IF 

INP=’*’ 

GOTO  1000 

END  IF 

CHECK  THAT  THE  BASE  MAP  .MM  FILE  EXISTS 
IF  ((J+l)  .GT.  38)  THEN 

TEMP (38: 40)=' . MM' 

ELSE 

TEMP(J+1 : J+3>=* .  MM’ 

END  IF 

INQUIRE  (FILE=TEMP,  EX IST=FLAG) 

IF  (.NOT.  FLAG)  THEN 

ST ( 3 ) = 1 
CMD ( 1 ) =’  ’ 

CALL  MENUWR (RC, 4, 3, 3, CMD, 0,  1,ST) 

IST=1 

IF  (INP  .EQ.  ’*»)  CALL  MENUSV (SMFILE, £51, RC, 4, SMUNIT) 
CALL  MESS (5  RC (4, 1 ) , RC (4, 2) , RC (4, 3) , 7) 

GOTO  100 
END  IF 

OPEN  THE  BASE  FILE  THE  USER  SELECTED  TO  CHECK  AND  SEE  IF  THE  MAP  FILE 
THE  USER  SELECTED  CAN  BE  FOUND 
TEMP=TEXT ( 1 ) 

CALL  PACK (TEMP, J) 

OPEN  (MUNIT,  FILE=TEMP,  STATUS=’  OLD’ , ACCESS*’ DIRECT’ , RECL=50, 

*  FORM* ’ FORMATTED ’  ) 

C  READ  IN  THE  HEADER  DATA  TELLING  HOW  MANY  RECORDS  ARE  IN  THE  FILE 
READ (MUNIT, ’ (14)’ , REC=1)  HDR 

C  SEARCH  THE  BASE  MAP  FILE  FOR  A  MATCH  TO  THE  SELECTED  FILE  NAME 
DO  £00  I*£, HDR, 1 

READ (MUNIT, ’ (A48) ’ , REC=I )  10 
IF  (10(1:40)  .EQ.  TEXT (2) >  GOTO  £50 
£00  CONTINUE 
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C  NO  MATCH  FOUND,  DISPLAY  AN  ERROR  MESSAGE 

ST (3) =1 
CMD ( 1 )  =’  ’ 

CALL  MENUWR(RC,  4,  3,  3,  CMD, 0, 1, ST) 

CALL  MESS (5,  RC (4,  1 ) ,  RC (4,  2) , RC  <4, 3) , 7> 

IST=2 
GOTO  100 

MATCH  FOUND  IN  THE  BASE  MAP  FILE 
50  CALL  MESS (4,  RC (4,  1 ) ,  RC (4,  2) , RC (4, 3) , 1 ) 

CLOSE  (MUNIT) 

GET  THE  STARTING  AND  STOPPING  LOCATION  IN  THE  BASE  MAP  .MM  FILE 
WHERE  THE  SELECTED  MAP  DATA  CAN  BE  FOUND 
READ< 10(41 :4fl) , ’ (214) ’ )  IS, IE 
ISS=IS 
IEE=IE 

SET  THE  BASE  MAP  .MM  FILE  NAME 
IF  ((J+l)  .GT.  38)  THEN 

TEMP (38: 40)=’ . MM’ 

ELSE 

TEMP(J+1:J+3)=’.MM* 

END  IF 

OPEN  THE  BASE  FILE  .MM  TO  PROCESS  THE  MAP 

OPEN  (MUNIT, FILE=TEMP, STATUS*’ OLD’ , ACCESS*’ DIRECT’ , RECL=42, 

*  FORM*’ FORMATTED’  > 

READ  IN  THE  FIRST  RECORD,  WHICH  SHOULD  BE  THE  MAP  NAME 
READ (MUNIT, ’ (A40) ’, REC=IS)  IOP 

THE  MAP  NAME  IN  THE  FILE  MUST  AGREE  WITH  THE  MAP  NAME  GIVEN 
IF  (IOP  .  NE.  TEXT (2) )  THEN 

ST (3) *1 
CMD ( 1 ) =’  * 

CALL  MENUWR ( RC, 4, 3, 3, CMD, 0, 1, ST) 

CALL  MESS (20,  RC (4, 1 ) , RC (4, 2) , RC (4, 3) , 7) 

CLOSE  (MUNIT) 

GOTO  150 
END  IF 

READ  IN  THE  VIRTUAL  LOWER  AND  UPPER  X  AND  Y 
READ (MUNIT, ’ (2F10. 2) ’ , REC=IS+7)  VLX, VLY 
READ (MUNIT, ’ (2F10. 2)’ , REC=IS+8)  VUX, VUY 

INITIALZE  THE  PLOT  DEVICE,  DRAW  A  FRAME  AROUND  THE  MAP  AREA  AND  TITLE 
THE  PLOT,  CONVERT  THE  FLOATING  POINT  DATA  TO  INTEGER  DATA 
I VLX* VLX 
I VLY=VLY 
IVUX=VUX 
IVUY=VUY 

CALL  PL INI T ( I VLX, I VLY, I VUX, I VUY) 

IF  OLD  MAP  THEN  SELECT  THE  SITE  WHERE  THE  CORRIDOR  IS  TO  GO  AND  PLACE 
THE  LEGEND  ON  THE  MAP  WITH  THE  CORRIDOR  INFORMATION 
IF  (FLAG1)  THEN 

CALL  TCLIST ( ITR, SMUNIT, SMFILE, MUNIT, ISS, I EE, TCP, FLAGS) 

CALL  LEGEND ( IVUX, IVUY, TCP, STAMPS) 
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CALL  PLDONE 
CLOSE  (MUNIT) 

FLAG1=. FALSE. 

GOTO  £0 
END  IF 

C  FOR  A  NEW  MAP  DRAW  A  FRAME  AROUND  IT 

CALL  FRAME (TEXT (£> , IVLX, IVLY,  IVUX,  IVUY, 1,0) 

C  SET  THE  RECORD  POINTER  TO  THE  FIRST  DATA  RECORD 
IS=IS+15 

C  CHECK  TO  SEE  IF  THE  END  OF  THIS  MAP  FILE  HAS  BEEN  REACHED 
300  IF  (IS  .GT.  IE)  THEN 

FLAGS  ENABLES  THE  USER  TO  DRAW  ONLY  THE  MAP  WITHOUT 
DISPLAYING  ANY  CORRIDORS  ON  IT. 

TRUE  ==>  DISPLAY  THE  CORRIDOR  DATA 
FALSE  ==>  DO  NOT  DISPLAY  CORRIDOR  DATA 
FLAGS®. TRUE. 

CALL  TCLIST ( ITR, SMUNIT, SMFILE, MUNIT, ISS,  I EE,  TCP,  FLAGS) 
IF  (FLAGS)  CALL  LEGEND ( IVUX, IVUY, TCP, STAMPS) 

CALL  PLDONE 
CLOSE  (MUNIT) 

GOTO  £0 
END  IF 

READ  IN  THE  DATA  ID  RECORD 

WCS  IS  AN  INTEGER  ARRAY  THAT  HOLDS  THE  W (EIGHT) C (OLOR) S (TYLE)  OF 
THE  ITEM  TO  BE  DRAWN 

READ (MUNIT, *  (6IS,  F4.  S,  214,  A16) * , REC=IS)  ID, SN, NPTS, WCS ( 1 ) , WCS (£> , 

*  WCS ( 3 ) , SCALE, ANGLE, RECNO, ANNO 

C  READ  IN  THE  ANNOTATION  FOR  DATA  ITEM 

READ (MUNIT, *  (SF10. S, AS0)  ’  ,  REC=IS+1 )  AX, AY, ANNO 

C  IF  THE  ANNOTATION  IS  NOT  BLANK  THEN  PLDT  THE  TEXT 
IF  (ANNO  .NE.  *  ’)  THEN 

IAX=AX 

IAY*AY 

CALL  PLTEXT ( IAX, I AY, £, 0, ANNO,  £0,  WCS) 

END  IF 

C  ID  IS  A  POINT,  THIS  MEANS  A  MARKER  NEEDS  TO  BE  DRAWN 
IF  (ID  .EQ.  10)  THEN 

READ  (MUNIT,  MSF10.  S>  *  ,  REC®IS+£)  VX,  VY 

IVX=VX 

IVY=VY 

SYM=  MARKS (SN) 

CALL  MARKER (SYM,  IVX, IVY, WCS, SCALE, ANGLE) 

IS=IS+3 
GOTO  300 
END  IF 

C  ID  IS  A  LINE 

IF  (ID  .EQ.  11)  THEN 
IS=IS+3 

NREC=NPTS/2+M0D (NPTS,  £) 

IREC*1 

IPTS=0 
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ARE  ANY  MORE  LINE  RECORDS  TO  BE  READ 
IF  (IREC  .GT.  NREC>  THEN 

IS»IS+NREC 
GOTO  300 
END  IF 

FIND  OUT  HOW  MANY  POINTS  ARE  VALID  ON  THE  RECORD 
IF  ( (IPTS+2)  .GT.  NPTS)  THEN 

IFLG=1 
ELSE 
IFLG=2 
END  IF 

IPTS=IPTS+IFLG 
READ  IN  THE  RECORD 

READ (MUNIT, ’ (4F10. 2) » , REC=IS+IREC-1 )  VX, VY, VX1, VY1 
IVX=VX 

IVY=VY  f 

IF  (IREC  .EQ.  1)  THEN 

CALL  MOVETOdVX,  IVY) 

ELSE 

CALL  LINETO (IVX, IVY, WCS) 

END  IF 

IF  THERE  ARE  TWO  POINTS  DISPLAY  THE  SECOND 

IVX=VX1 

IVY=VY1 

IF  ( IFLG  .EQ.  2)  CALL  LINETO (IVX, IVY, WCS) 

IREC=IREC+1 

GOTO  400 

END  IF 

ID  IS  A  POLYGON  —  END  POINTS  MUST  BE  CONNECTED 
IF  (ID  .EQ.  12)  THEN 
IS=IS+3 

NREC=NPTS/2+M0D (NPTS,  2) 

I REC=1 
IPTS=0 

ARE  ANY  MORE  LINE  RECORDS  TO  BE  READ 
IF  (IREC  .GT.  NREC)  THEN 

CALL  LINETO (ISX, ISY, WCS) 

IS*IS+NREC 

GOTO  300 

END  IF 

FIND  OUT  HOW  MANY  POINTS  ARE  VALID  ON  THE  RECORD 
IF  ((IPTS+2)  .GT.  NPTS)  THEN 

IFLG=1 

ELSE 

IFLG=2 

ENDIF 

IPTS=IPTS+IFLG 

npnn  tm  tup  Dcrnon 

READ(MUNIT, ’ (4F10. 2) * , REC-IS+IREC-1 )  VX, VY, VX1, VY1 
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IVY=VY 

IF  (IREC  .EQ.  1)  THEN 

CALL  MOVETO ( I V  X ,  I V Y ) 

ISX=IVX 

ISY=IVY 

ELSE 

CALL  LINETQ ( IVX, IVY, WCS) 
END  IF 

C  IF  THERE  ARE  TWO  POINTS  DISPLAY  THE  SECOND 

IVX=VX1 
IVY=VY1 

IF  (IFLG  .EQ.  2)  CALL  LINETO ( IVX, IVY, WCS) 

IREC=IREC+1 

GOTO  500 

END  IF 


END 

SUBROUTINE  MOST (TEXT,  MUNIT,  FNAME,  SMUNIT,  SMFILE,  ITR,  EFLAG, 

*  IREC, IMN) 

C****************************************************************************** 
THIS  SUBROUTINE  DISPLAYS  A  LIST  OF  THE  BASE  FILE  NAMES  OR  MAP  FILE  NAMES 
VARIABLES  PASSED t 


MUNIT 

FNAME 

SMUNIT 

SMFILE 

ITR 

IREC 


IMN 


UNIT  #  TO  OPEN  THE  SUPER  DIRECTORY  OR  BASE  MAP  FILES  ON 
NAME  OF  FILE  TO  BE  OPENED  ON  MUNIT 
UNIT  #  TO  OPEN  MENU  FILE  ON  (SMFILE) 

MENU  FILE  NAME 

INTERACTIVE  TERMINAL  READ  UNIT 

RECORD  LENGTH  TO  OPEN  THE  FILE  WITH 

42  ==>  SUPER  DIRECTORY  FILE 

50  ==)  BASE  MAP  FILE 

MENU  NUMBER  TO  DISPLAY 

252  ==>  SUPER  DIRECTORY  MENU 

251  ==)  BASE  MAP  MENU 


VARIABLES  RETURNED: 

TEXT  -  NAME  OF  BASE  OR  MAP  FILE  USER  SELECTED 

EFLAG  -  FLAG  TO  DETERMINE  IF  THERE  WERE  ANY  ENTRIES  IN  THE  FILE 

1  ==>  NO  ENTRIES  FOUND 

0  . ==)  ENTRIES  WERE  FOUND 

*****#*********#***#*#*******##-ihhhhhhhhi-*##******#*#****##**#*******###*****## 


CHARACTER*70 

CHARACTER*40 

CHARACTER*? 

CHARACTER*3 


OUT (19) 

10, TEXT, FNAME 

SMFILE 

CMD ( 1 ) 


INTEGER  SMUNIT,  RC < 19,  3),  ST (3),  ICNT,  ITR,  MUNIT,  EFLAG,  HD, 

*  IREC, IMN 


LOGICAL  FLAG1 


DATA  ST/0,0,0/ 

OPEN  THE  FILE  AND  READ  IN  THE  HEADER  RECORD  TO  FIND  OUT  HOW  MANY  RECORDS 
ARE  IN  THE  FILE 

OPEN  (MUNIT,  FILE=FNAME,  STATUS*’  OLD’ , RECL-IREC, ACCESS*’ DIRECT’ , 

*  FORM*’  FORMATTED’  ) 
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READ (MUNIT, ’ (I4)’,REC=1)  HD 


C  SET  THE  ERROR  FLAG 

EFLAG=0 

IF  (HD  .LE.  1)  THEN 

EFLAG=1 
RETURN 
END  IF 

5  ICNT=2 

FLAG 1=. FALSE. 

C  FORM  THE  LIST  OF  FILES  THE  USER  CAN  SELECT  FROM 
DO  £0  I=£, HD, 1 

IF  (.NOT.  FLAG1)  FLAG 1=. TRUE. 

READ  (MUNIT,  MA40)’ ,  REC=I)  10 
OUT (ICNT) (1:70)=’  ’ 

WRITE (OUT ( ICNT) (1:3),’ (13)’)  I 
OUT ( ICNT)  <6:70)=IO 

C  CAN  ONLY  DISPLAY  19  NAMES  ON  THE  SCREEN  AT  ONCE 

IF  (ICNT  .EQ.  19)  THEN 

CALL  MENUSV (SMFILE,  IMN,  RC,  19,  SMUNIT) 

CALL  MENUWR(RC,  19,  2,  19,  OUT,  0,  1, ST) 

INPUT  THE  USERS  CHOICE 
5  CMD ( 1 ) =’  ’ 

CALL  MENURD (RC,  19,  1,  1,CMD, ITR) 

USER  SELECTED  TO  RETURN,  CLOSE  THE  MAP  UNIT  FIRST 
IF  (CMD ( 1 )  .EQ.  ’X  ’)  THEN 

CLOSE  (MUNIT) 

RETURN 
END  IF 

THE  USER  WANTS  TO  CONTINUE 
IF  (CMD ( 1 )  .EQ.  ’C  ’)  THEN 

ICNT=2 

FLAG1=. FALSE. 

GOTO  20 
END  IF 

CHECK  FILE  THE  USER  SELECTED  IS  IN  THE  USABLE  RANGE 
READ (CMD ( 1 ) (1:3),’ ( 13) ’ , ERR=15)  II 
IF  ((II  .LT.  2).  OR.  (II  .GT.  HD) >  GOTO  15 

USER  SELECTED  A  USABLE  FILE,  STORE  IT  IN  TEXT,  CLOSE  THE  FILE,  AND 
RETURN 

READ ( MUN I T, ' ( A40 ) ’ , REC= II)  TEXT 
CLOSE  (MUNIT) 

RETURN 

ENDIF 

ICNT=ICNT+1 
£0  CONTINUE 

C  THERE  WERE  LESS  THAN  19  FILES  TO  DISPLAY 

IF  (.NOT.  FLAG1 )  GOTO  5 

C  DISPLAY  THE  MENU  AND  THE  FILE  NAMES 

CALL  MENUSV (SMFILE,  IMN, RC,  19, SMUNIT) 
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CALL  MENUWR (RC,  19,2,  ICNT-1 ,  OUT,  0, 1,ST) 


C  INPUT  THE  USERS  CHOICE 

25  CMD ( 1 )  =*  ’ 

CALL  MENURD (RC, 19,  1,  1,CMD,  ITR) 

C  THE  USER  WANTS  TO  RETURN 

IF  (CMD ( 1 )  .EQ.  ’X  ’>  THEN 

CLOSE  (MUNIT) 

RETURN 
END  IF 

C  THE  USER  WANTS  TO  CONTINUE  VIEWING  THE  LIST 
IF  (CMD(l)  .EQ.  ’C  M  THEN 

FLAG 1=. FALSE. 

GOTO  5 
END  IF 

C  CHECK  THAT  THE  USERS  INPUT  IS  VALID 
READ (CMD ( 1 )  (1:3), ’  ( 13) ’ , ERR=25>  II 
IF  ((II  .LT.  2). OR. (II  .GT.  HD))  GOTO  25 

C  THE  INPUT  IS  VALID,  STORE  THE  VALID  FILE  NAME  IN  TEXT 
READ(MUNIT,  ’ (A40) ' , REC=I I )  TEXT 
CLOSE  (MUNIT) 

RETURN 

END 

SUBROUTINE  TCLIST( ITR,  SMUNIT,  SMFILE, MUNIT, IS, IE, TCP, FLAG) 

C****************************************************************************** 
THIS  SUBROUTINE  IS  USED  TO  INPUT  THE  SITE  (COORDINATES)  WHERE  THE  TOXIC 
CORRIDOR  IS  TO  BE  PLOTTED 
VARIABLES  PASSED i 

ITR  -  INTERACTIVE  TERMINAL  READ  UNIT 
SMUNIT  -  UNIT  #  TO  OPEN  MENU  FILE  (SMFILE)  ON 
SMFILE  -  MENU  FILE  NAME 

MUNIT  -  UNIT  ft  TO  OPEN  THE  BASE  MAP  .MM  FILE  ON 
IS  -  STARTING  RECORD  OF  INTEREST  IN  BASE  MAP  .MM  FILE 

IE  -  ENDING  RECORD  OF  INTEREST  IN  BASE  MAP  .MM  FILE 

TCP  -  TOXIC  CORRIDOR  PARAMETERS  NEEDED  TO  PLOT  THE  CORRIDOR 

VARIABLES  RETURNED: 

FLAG  -  FLAG  TO  DETERMINE  WHETHER  THE  LEGEND  WILL  BE  DRAWN  ON  THE  MAP 
TRUE  '  »=>  THE  LEGEND  IS  TO  BE  DRAWN 
FALSE  *=>  THE  LEGEND  IS  NOT  TO  BE  DRAWN 
O***************************************************************************** 


CHARACTER*20  TEXT ( 1 ) 
CHARACTER* 10  DIG (2) 
CHARACTER*?  SMFILE 
CHARACTER* 1  CMD ( 1 ) , I NP 


INTEGER 

REAL 

LOGICAL 


ITR, SMUNIT, IX, IY, IF1, RC(5, 3), ITT,  ST (3) ,  WCS (3) ,  NCOR 

TCP (6),  DC (4),  CORDIR,  CORWID 

FLAG 


n  n 


DATA  ST  /0,  0,0/ 

DATA  WCS  /l, 1, 1/ 

ITT=-1 

INp=i  » 

TEXT ( 1 )  ( 1  :£0)  ='  » 

DIG ( 1 ) (1:10)='  ’ 

DIG (2) ( 1 : 10)  =*  * 

C  DISPLAY  THE  MENU 

1000  CALL  MENUSV(SMFILE,  254,  RC, 5, SMUNIT) 

C  CHECK  THAT  A  ?  WAS  USED  FOR  THE  SITE 
IF  (INP  .EQ.  ’*•  )  THEN 

ST (3) =1 

CALL  MENUWR ( RC,  5,  1,  1,TEXT,  0,  1,ST> 

WRITE (DIG ( 1 ) (1:10), 1 (17)*)  IX 
WRITE (DIG (2) (1:10),' (17)’ )  IY 
CALL  MENUWR (RC, 5, 2, 3, DIG, 0, 1,ST> 

GOTO  100 
END  IF 

C  READ  IN  THE  SITE  NAME 

25  CALL  MENURD(RC,5,  1,  1,  TEXT, ITR) 

IF  A  ?  WAS  ENTERED  FOR  THE  SITE,  THEN  DISPALY  A  LIST  OF  ALL  POSSIBLE 
SOURCES 

IF  (TEXT ( 1 )  .EQ.  *?»)  THEN 

CALL  TCSITE (ITR,  SMUNIT,  SMFILE,  MUNIT, IS, IE, TEXT ( 1 ) , IX, IY) 

INP=’  *» 

GOTO  1000 
END  IF 

C  READ  IN  THE  CDORDINMES 

IST=2 

30  CALL  MENURD(RC,5, 1ST, 3, DIG, ITT) 

READ (DIG ( 1 ) (1:10),'  (F10.  0) ' ,  ERR=50>  VX 
READ (DIG (2) ( 1 : 10) , ’  (F10.  0) ’ ,  ERR=55)  VY 
IX=VX 
I  Y=VY 
GOTO  100 

C  ERROR  RECOVERY  FOR  THE  QDOFDINATES 

50  IST=2 

CALL  MESS ( 1,  RC (5,  1 ) , RC (5, 2) , RC (5, 3) , 7) 

GOTO  30 
55  IST=3 

CALL  MESS  ( 1,  RC  (5,  1 ) ,  RC  (5,  2) ,  RC  (5,  3) ,  7) 

GOTO  30 

C  SCAN  THE  COMMAND  INPUT  LINE 

100  CMD ( 1 )  =’  ’ 

CALL  MENURD(RC,5,  4,  4,  CMD,  ITT) 

C  USER  WANTS  TO  GO  BACK  TO  THE  SITE  ENTRY 
IF  (CMD(l)  .EQ.  ’  ’)  THEN 

ST (3) =1 

CALL  MENUWR ( RC, 5, 4,  4,  CMD, 0, 1 , ST) 

CALL  MESS (4, RC (5, 1 ) , RC (5, 2) , RC (5,  3) ,  1 > 


nnn 


GOTO  £5 
END  IF 


C  USER  WANTS  TO  RETURN,  AND  NOT  DRAW  THE  LEGEND 
IF  (CMD(l)  .EQ.  ’XM  THEN 

FLAG®. FALSE. 

RETURN 
END  IF 

C  USER  WNATS  TO  DRAW  THE  CORRIDOR  ON  THE  MAP  AND  A  LEGEND 
IF  (CMD(l)  .EQ.  ’PM  THEN 

PLOT  THE  CIRCLES  FOR  1®,  3®,  6®  PEL  AND  IB®®  FT 
PRIORITY  ZONE 

DC ( 1 ) =  TCP ( 1) 

DC (£) =  TCP (2) 

DC (3) =  TCP (3) 

DC (4)  =  18O0.0 
CORWID*  TCP (4) 

CORD I R®  TCP (5> 

CALL  DRWCOR (IX, IY, DC, 4, CORWID,  CORDIR) 

C 

RETURN 
END  IF 

GOTO  100 
END 

SUBROUTINE  TCSITE ( ITR,  SMUNIT,  SMFILE,  MUNIT, IS, IE, SITE, IX, IY) 

C****************************************************************************** 
C  THIS  SUBROUTINE  SEARCHES  THE  BASE  MAP  .MM  FILE  AND  LISTS  ALL  THE  POSSSIBLE 
C  SOURCES  THAT  COULD  BE  USED  TO  DRAW  THE  CORRIDOR  AROUND 
C  VARIABLES  PASSED: 

C 

C  ITR  -  INTERACTIVE  TERMINAL  READ  UNIT 

C  SMUNIT  -  UNIT  #  TO  OPEN  MENU  FILE  (SMFILE)  ON 

C  SMFILE  -  MENU  FILE  NAME 

C  MUNIT  -  UNIT  #  TO  OPEN  BASE  MAP  .MM  ON 

C  IS  STARTING  RECORD  IN  BASE  MAP  .MM 

C  IE  -  ENDING  RECORD  IN  BASE  MAP  .MM 

C 

C  '  VARIABLES  RETURNED: 

C 

C  SITE  -  SITE  THAT  THE  USER  SELECTED 

C  IX  -  X  COORDINATE  OF  THE  SITE 

C  IY  -  Y  COORDINATE  OF  THE  SITE 

C****************************************************************************** 


CHARACTE  R*7®  OUT (19) 
CHARACTER*4®  10 
CHARACTERS®  SITE 
CHARACTER*?  SMFILE 
CHARACTER*3  CMD ( 1 ) 


INTEGER  SMUNIT,  RC(£®, 3>,ST(3>, ICNT, ITR, MUNIT, EFLAB, HD, 

*  IREC,  IS, IE, IX, IY 


REAL 


CO ( 19, S) 
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CLHbl 


DATA  ST/0,0,0/ 

C  INITIALIZE  THE  CO-ORDINATE  ARRAY  TO  ALL  ZEROS 

DO  1  1*1, 19, 1 
CO (I, 1>=0. 

CO ( I, 2) =0. 

1  CONTINUE 

EFLAG* 1 

5  ICNT=2 

C  IREC  POINTS  TO  THE  FIRST  RECORD  OF  MAP  DATA 
IREC=IS+15 
FLAG1*. FALSE. 

20  IF  (.NOT.  FLAG1 )  FLAG1*. TRUE. 

READ (MUNIT,  ’  ( 12,  2X,  12,  1QX,  12)  •  ,  REC=I REC)  NSYM, NPTS, LINK 
READ (MUNIT, ’ (A40) ’ , REC=I REC+1 )  10 

TPFP-TBFr+?  / 

IF  (NSYM  .NE.  10)  IREC=IREC+1 

C  INPUT  THE. X  AND  Y  COORDINATE  OF  THE  SITE 

READ (MUNIT, * (2F10. 2) ’ , REC=I REC)  CO(ICNT, 1 ) , CO ( ICNT, 2) 

C  SET  IREC  TO  POINT  TO  THE  NEXT  RECORD 

IREC=IREC+ (NPTS/2) +MOD (NPTS, 2) 

C  IF  LINK  =  1  THEN  THE  ITEM  IN  THE  FILE  IS  A  POTENTIAL  SOURCE 

IF  (LINK  .NE.  1)  GOTO  21 

EFLAG  IS  USED  TO  DETERMINE  WHETHER  THERE  WERE  ANY  ITEMS  IN  THE  FILE 
THAT  WERE  POTENTIAL  SOURCES 
EFLAG  =0  ==)  NO  POTENTIAL  SOURCES 

EFLAG  =1  ==>  POTENTIAL  SOURCES 

EFLAG=0 

C  STORE  OF  THE  SITE  IN  AN  ARRAY 

OUT (ICNT) (1:70)=’  ’ 

WRITE (OUT (ICNT) (1:3),’ (13) ’ )  ICNT 
OUT ( ICNT) (6:25) =10 (21 : 40) 

C  CAN  ONLY  DISPLAY  19  SITES  ON  THE  SCREEN  AT  A  TIME 

IF  (ICNT  .EQ.  19)  THEN 

C  DISPLAY  THE  MAIN  MENU  AND  THE  LIST  OF  SITES 

CALL  MENUSV ( SMF I LE,  255, RC, 20, SMUNIT) 

CALL  MENUWR ( RC,  20,  2,  19,  OUT,  0, 1,ST) 

C  INPUT  THE  USERS  COMMAND 

15  CMD ( 1 ) =’  ’ 

CALL  MENURD(RC,  20, 1, 1, CMD, ITR) 

C  USER  SELECTED  TO  RETURN 

IF  (CMD ( 1 )  .EQ.  ’X  ’)  RETURN 

C  USER  WANTS  TO  CONTINUE  AND  SEE  MORE  OF  LIST 

IF  (CMD ( 1 )  .EQ.  ’C  ’)  THEN 

ICNT=2 

FLAG1*.  FALSE. 


97 


c 

c 
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GOTO  20 
END  IF 

G  CHECK  THAT  THE  USER  SELECTED  A  VALID  SITE 

READ<CMD(1) (1:3),’  ( 13) ’ ,  ERR-I5)  II 
IF  ((II  .LT.  2). OR. (II  .GT.  19))  GOTO  15 

C  STORE  OFF  THE  SITE  AND  COORDINATES  AND  RETURN 

SITE (1 :20) =QUT (II) (6:25) 

IX«CO(II, 1) 

IY=CO(II, 2) 

RETURN 

END  IF 

ICNT=ICNT+1 

21  IF  (IREC  .LE.  IE)  GOTO  20 
IF  (.NOT.  FLAG 1 )  GOTO  5 

C  DISPLAY  THE  MENU  AND  ANY  SITES  NAMES  FOUND 
CALL  MENUSV (SMFILE, 255, RC, 20, SMUNIT) 

IF  THERE  ARE  NO  SITES  WHICH  ARE  POTENTIAL  SOURCES  DISPLAY  A  MESSAGE 
AND  ALLOW  THE  USER  TO  ONLY  RETURN 
IF  (EFLAG  .NE.  0)  THEN 

CALL  MESS (5, RC (20, 1 ) , RC (20, 2) , RC (20, 3) , 7) 

CMD ( 1 ) ■’  ’ 

CALL  MENURD (RC, 20, 1,1, CMD, ITR) 

IF  (CMD ( 1 )  .NE.  ’X  *>  GOTO  24 

RETURN 

END  IF 

CALL  MENUWR ( RC, 20,  2,  ICNT- 1 , OUT , 0, 1 , ST ) 

C  INPUT  THE  USERS  SELECTION 

25  CMD ( 1 ) -*  ’ 

CALL  MENURD (RC, 20,  1,  1,CMD,  ITR) 

C  USER  SELECTED  TO  RETURN 

IF  (CMD ( 1 )  .EQ.  ’X  ’)  RETURN 

C  USER  SELECTED  TO  CONTINUE  VIEWING  THE  LIST 
IF  (CMD ( 1 )  .EQ.  ’C  ’)  THEN 

FLAG1=.  FALSE. 

GOTO  5 
END  IF 


.  I 


/ ! 


.!  -d 


C 

c 

c 

c 


CHECK  THAT  THE  USER  SELECTED  A  VALID  SITE 
READ(CMDd)  (1:3)  ,*  ( 13)  ’ ,  ERR«=25>  II 
IF  ((II  .LT.  2). OR. (II  .GT.  19))  GOTO  25 

STORE  OFF  THE  SITE  AND  COORIDINATES 
SITE ( 1 :20) ®OUT (II) (6:25) 

IX=CO(Ii; 1) 

IY=CO ( I I , 2) 

RETURN 

END 

SUBROUTINE  DRWCORUX,  IY,  TCL,  NCOR,  CORWID,  CORDIR) 


ARGUMENT 

IX 

IY 


TYPE 

INTEGER*4 


DESCRIPTION 

VIRTUAL  X  COORDINATE  OF  CORRIDOR  STARTING  POINT 

N  y  M  M  II  M  II 
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TCL (NCOR) 


NCOR 
CORWID 
CORD I R 


REAL*4 


INTEGER*4 

REAL*4 

REAL*4 


TCL ( 1 )  :  10  MIN  PEL  DISTANCE 
TCL (2) :  30  " 

TCL (3):  60  " 

TCL (4— NCOR) :  OPTIONAL  CORRIDOR  LENGTHS 
NUMBER  OF  CORRIDORS  TO  PLOT 
CORRIDOR  WITH  (DEGREES) 

"  DIRECTION  (DEGREES) 


INTEGER 

REAL 


tv  tv  Kirne 

TCL (NCOR),  CORWID,  CORDIR 


PROGRAM  VARIABLES 


INTEGER  WCS (3) ,  IR,  1X1,  IY1,  1X2,  IY2,  ICORL 

REAL  ANG1,  ANG2,  RADCOR,  RADDIR 

CHARACTER*! 0  COORD(l) 


10 

C 


20 

C 


WCS(1)=  0 
WCS (3)  =  1 
ICORL=  -1. 

DO  10  1=1,3, 1 

IF (  TCL ( I ) . GT. 0. )  THEN 
IR=TCL( I ) 

ICORL=  MAX0(IR, ICORL) 

WCS (2) =1+4 

CALL  CIRCLEdX,  IY,  IR.WCS) 
END  IF 
CONTINUE 

IF (  NCOR.  GT.  3  >  THEN 
WCS<3)=  0 
DO  20  1=4,  NCOR,  1 

IF (  TCL(I) .  GT.  0.  >  THEN 
I R=TCL ( I ) 

ICORL=  MAX0(IR, ICORL) 

WCS (2) =1+4 

CALL  CIRCLEdX,  IY,  IR,  WCS) 
END  IF 
CONTINUE 
END  IF 

IF (  ICORL. GT.0  )  THEN 
RADCOR®  CORWID/57. 3 
RADDI R=  (90. -CORDIR) /57.  3 
ANG1=  RADDIR  -  (RADCOR/2. 0) 
ANG2=  RADDIR  +  (RADCOR/2. 0) 
1X1=  IX+(  ICORL*COS (ANSI )  > 
IY1=  IY+ (  ICORL*SIN ( ANG1 )  ) 
1X2=  IX+(  ICORL*COS (ANG2)  > 
IY2=  IY+ (  ICORL*SIN (ANG2)  ) 
CALL  MOVETO (IX, IY) 

WCS(1)=  0 
WCS (2) =  1 
WCS (3) =  0 

CALL  LINETOdXl,  IY1,WCS> 

CALL  MO VETO (IX, I Y) 

CALL  LINET0(IX2, IY2, WCS) 

END  IF 
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RETURN 

END 


C 

C 

C 

C 

C 

C 

C 

C 

C 

C 


SUBROUTINE  LEGEND (VUX,  VUY,  TCP, STAMPS) 


LEGEND  PLOTS  TIME,  DATE  AND  CORRIDOR  INFORMATION  IN  TEXT  FORM 


ARGUMENT 
VUX 
VUY 
TCP (5) 
TITLE(l) 
STAMPS (2) 


TYPE 

INTEGER 

INTEGER 

INTEGER 

CHARACTER*40 

CHARACTER*15 


DESCRIPTION 

UPPER  LEFT  X  VIRTUAL  COORDINATE 

i«  «•  Y  ii  a 

CORRIDOR  LENGTHS,  WIDTH  AND  DIRECTION 
MAP  TITLE 

TIME  AND  DATE  STAMPS 


INTEGER 

REAL 

CHARACTER* 15 


VUX, VUY 
TCP (5) 
STAMPS (2) 


PROGRAM  VARIABLES 

INTEGER  SPEL<3) ,  WCS(3) ,  SIZE,  IX, IY, 1X1, IY1 

CHARACTER*80  TS  < 1 ) 


INITIALIZE  LINE  EXPOSURE  LIMIT  (SPED  AND  LINE  ATTRIBUTE  (WCS)  ARRAYS 

SPEL ( 1 ) *  10 
SPEL  ( 2 )  *  30 
SPEL (3) «  60 
WCS ( 1 ) *  0 
WCS (2) *  1 
WCS (3)  =  0 

CALL  CHRSIZ (3, SIZE) 

SIZE=  1. 5*SIZE 
IX*  VUX+ (4*SIZE) 

IY*  VUY- (4*SIZE) 

WRITE(TSd)  (1:22),’  (’’TIME:  **,A15)*>  STAMPS(l) 

CALL  PLTEXT ( IX,  IY,  3,  0,  TS ( 1 ) , 22, WCS) 

IY*  IY-SIZE 

WRITE (TS(1)  (1:22),*  (’’DATE:  ”,A15>’>  STAMPS (2) 

CALL  PLTEXT (IX, I Y,  3,  0,  TS ( 1 ) ,  22,  WCS) 

IY*  IY- (2*SIZE) 

CALL  PLTEXT ( IX,  IY, 3,  0, '  CORRIDOR  INFORMATION’ , 26, WCS) 

IY*  IY- (1. 2*SI ZE) 

CALL  PLTEXT (IX,  I Y,  3,0,  ’OCEAN  BREEZE  -  DRY  GULCH  EQUATION* , 33, WCS) 
IY*  IY-SIZE 

CALL  PLTEXT ( IX, I Y, 3,0,  ’  (BASED  ONLY  ON  DELTA  T>’,26, WCS) 
WRITE(TS(1)  (1:18),’  (’’DIRECTION:  ”  , F6. 1 ) * >  TCP(5) 

IY*  IY- ( 1. £5*SIZE) 

CALL  PLTEXT (IX, IY, 3, 0, TS ( 1 ) , 18, WCS) 

WRITE(TSd)  (1:18),’  (’’WIDTH  i  ”,F6.1)’>  TCP(4) 

IY-  IY-SIZE 

CALL  PLTEXT  (IX,  IY,3,0,  TSd),  18,  WCS) 

PLOT  CORRIDOR  LINES  AND  DESCRIPTIONS 


n  n  n  n  n  n  n 
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I Y=  IY-(£*SIZE> 

1X1  =  IX+ (5*SIZE> 

DO  10  1=1,  3 

IF (  TCP ( I ) . GT. 0. 0  )  THEN 
WCS  <  £ ) =  1+4 
WCS (3) =  1 

CALL  MOVETOdX,  I Y> 

CALL  LINETOdXl,  IY,WCS> 

WCS (£>  =  1 
WCS (3) =  0 

WRITE(TSd)  (1:16),  ’  (”  :  ”,I£,”  MINSPEL”)’)  SPELd) 

IY1=  IY-  (SIZE/3) 

CALL  PLTEXT (I XI,  IY1,  3,  0,  TS ( 1 ) , 16, WCS) 

IY=  IY-SIZE 

END  IF 

CONTINUE 

WCS (2) =  8 

WCS (3) =  0 

CALL  MOVETOdX,  IY> 

CALL  LINETOdXl,  IY,  WCS) 

WCS (£) =  1 
I Yl=  IY- (SI ZE/3) 

CALL  PLTEXTdXi,  IY1,3,0,  ’  :  PRIORITY  ZONE’ ,  18,  WCS) 

IY1=  IY1-SIZE 

CALL  PLTEXTdXi,  IY1, 3,0,  ’  (1800  FEET)  ’,18, WCS) 

RETURN 

END 


SUBROUTINE  SCLPLT (I X, IY, FPI ) 

ARGUMENT  TYPE  DESCRIPTION 

IX  INTEGER*4  VIRTUAL  LOWER  LEFT  X  COORDINATE  OF  SCALE  PLOT 

IY  INTEGER*4  "  "  "  Y 

FPI  REAL*4  MAP  SCALE  (FT/ INCH) 

PROGRAM  VARAIBLES 

INTEGER  I XX,  IYY,  1X1,  IY1,  IY£,WCS(3), IFPI 

REAL  VUINTS 

CHARACTER*£0  TEMP ( 1 ) 

IXX=  IX 
I YY=  IY 
WCS(l)*  0 
WCS (£) =  1 
WCS (3) =  0 
IFPI=  FPI 

WRITE  (TEMP  (l)(lil8),’  (”1  INCH=”  ,  16,  ”  FEET”)’)  IFPI 
CALL  VUINCH (VUNITS) 

CALL  PLTEXT (IXX,  I YY,  3,  0,  TEMP ( 1 ) , 18, WCS) 

IYY=  I YY+  (VUNITS*. 33) 

IY1»  IYY+  (VUNITS*. 1) 

I Y£=  IYY-  (VUNITS*. 1) 

1X1=  IXX+  VUNITS 
CALL  MOVETOdXX,  IYY) 

CALL  LINETOdXl,  IYY,  WCS) 

CALL  MOVETOdXX,  I Yl) 

CALL  LINETOdXX,  IY2,  WCS) 

CALL  MOVETO (I X 1 , IY1) 


CALL  LINETO <1X1, IY2, WCS) 

IXX-  IXX+  (VUNITS*. 5) 

IYY=  IYY+  (VUNITS*. 33) 

CALL  MQVETOdXX,  IYY) 

IYY*  IYY+  (VUNITS*1. 5) 

CALL  LINETOdXX,  IYY,  WCS) 

IXX*  IXX+  (VUNITS*.!) 

IYY*  IYY-  (VUNITS*.  2) 

CALL  LINETOdXX,  IYY,  WCS) 

CALL  PLTEXT (IXX,  IYY,  5,  9,  ’  NORTH’ ,  6, WCS) 
C 

RETURN 

END 


SUBROUTINE  FRAME (TITLE, VLX,  VLY, VUX, VUY, COLOR, STYLE) 
C 

C  ARGUMENT  TYPE  DESCRIPTION 


c 

TITLE(l) 

CHARACTER*40 

MAP  TITLE 

c 

VLX 

INTEGER*^ 

VIRTUAL  X 

LOWER  LEFT 

COORDINATE 

c 

VLY 

INTEGER*4 

«  Y 

II  II 

II 

c 

VUX 

INTEGER*4 

”  X 

UPPER  RIGHT 

II 

c 

VUY 

INTEGER*4 

„  y 

•1  II 

•I 

c 

COLOR 

INTEGER*4 

FRAME  LINE 

COLOR 

c 

p 

STYLE 

M 

II  II 

STYLE 

L 

INTEGER 

VLX, VLY, VUX 

, VUY, COLOR 

, STYLE 

CHARACTER**© 

TITLE ( 1 ) 

C 

C 

C  PROGRAM  VARIABLES 
C 

INTEGER  WCS (3) ,  IX, IY, SIZE 

C 
C 

C  LOAD  LINE  COLOR  AND  STYLE  INTO  WCS  ARRAY 
C 

WCS(1>-  0 
WCS (2)-  COLOR 
WCS ( 3 )  *  STYLE 
C 

C  DRAW  FRAME  AS  DEFINED  BY  VIRTUAL  COORDINATE  LIMITS 
C 

CALL  MOVETO(VLX, VLY) 

CALL  LINETO (VLX, VUY, WCS) 

CALL  LINETO (VUX, VUY, WCS) 

CALL  LINETO (VUX, VLY, WCS) 

CALL  LINETO (VLX, VLY, WCS) 

C 

CALL  CHRSI Z (6, SIZE) 

IX-  VLX+(5*SIZE> 

IY-  VUY+ (. 5*SIZE) 

CALL  PLTEXT (IX, IY,  6,  0,  TITLE d ) ,  40, WCS) 

C 

RETURN 

END 

SUBROUTINE  CORPLT (FPI, TCP, STAMPS) 

CHARACTER* 15  STAMPS (2) 


n  n 


REAL  FPI, TCP (5), TEMP (5), VUNITS 

CALL  PLINIT(0,0, £300, 1700) 

CALL  VU INCH (VUNITS) 

C  CONVERT  THE  CORRIDOR  TO  INCHES 

CORN ID  =TCP (4) 

CORDIR  =TCP (5) 

DO  5  1=1,  3, 1 

TEMP  < I ) =TCP< I ) 

IF  (TEMP (I)  .ST.  0.)  THEN 

TEMP ( I ) =TEMP ( I ) /FPI 
TEMP ( I ) =TEMP ( I ) * VUNITS 
END  IF 

5  CONTINUE 

TEMP (4) =  (1800. /FPI)  *  VUNITS 

C  DRAW  THE  CORRIDOR 

CALL  DRWCOR ( 1100,  875,  TEMP,  4,  CORWID, CORDIR) 

C  DRAW  THE  LEGEND 

IX=  1900 
I Y=  1950 

CALL  LEGEND (IX, I Y, TCP, STAMPS) 

C  DRAW  THE  SCALE 
IX=  2150 
I  Y=  0 

CALL  SCLPLT ( IX, IY, FPI ) 

FINISH  THE  PLOTTING 
CALL  PLDONE 

RETURN 
END 
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SUBROUTINE  PLINIT (VLX, VLY, VUX, VUY) 


PLOTTER  INITIALIZATION  SUBROUTINE 


ARGUMENTS 

VLX 

VLY 

VUX 

VUY 


TYPE 

INTEGER*4 

INTEGER*4 

INTEGER*4 

INTEGER*4 


DESCRIPTION 

VIRTUAL  LOWER  LEFT  X  COORDINATE 

ii  H  «i  y  it 

"  UPPER  RIGHT  X 

it  ii  ii  y  ii 


INTEGERS 


VLX,  VLY,  VUX,  VUY 


COMMON/ PLTVAR/  CHAN,  PSTATUlZU,  SCALEX,  SCALEY 
COMMON/ PLTLOC/  VXY 

INTEGER*4  CHAN,  PSTAT,VXY(4> 

REAL*4  SCALEX,  SCALEY 

COMMON  BLOCK  VARIABLES 


VARIABLE 

CHAN 

PSTAT (10) 
SCALEX 


TYPE 

INTEGER*4 

INTEGER*4 

REAL*4 


DESCRIPTION 

CHANNEL  ASSIGNED  TO  PLOTTER  BY  CROMIX 
STATUS  INFORMATION  FOR  PLOTTER 
X  SCALE  :  (PLOT  UNITS/VIRTUAL  UNITS) 


VXY (4 ) 


INTEGER*4  VXY(1)=  VLX 

VXY (£)  =  VLY 
VXY (3) =  VUX 
VXY (4) =  VUY 


PROGRAM  VARIABLES 

INTEGER  IWX, IWY 

REAL*4  DX,  DY,  ASPECT,  VSPECT 


LOAD  /PLTLOC/  COMMON  BLOCK 

VXY ( 1 )  =  VLX 
VXY (£)  =  VLY 
VXY (3)  =  VUX 
VXY (4) =  VUY 

CHECK  Y/X  ASPECT  RATIO  OF  VIRTUAL  LIMITS.  IF  THE  RATIO  IS  GREATER 
THAN  THE  ASPECT  RATIO  OF  THE  PLOTTER  (11/17)),  THE  SCALE  FACTORS  MUST 
BE  DEPENDENT  ON  THE  Y  DIMENSION  OF  THE  PLOT 

DX=  FLOAT (VUX-VLX) 

DY=  FLOAT (VUY-VLY) 

VSPECT=  DY/DX 
ASPECT*  17.0/30.0 
C 

IF (  VSPECT  .GT.  ASPECT  >  THEN 
SCALEY*  1700. 0/DY 
SCALEX*  SCALEY 

ELSE 

SCALEX*  3000. 0/DX 
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SCALEY-  SCALEX 

END  IF 

OPEN  A  CHANNEL  TO  THE  HOUSTON  PLOTTER  WITH  A  CALL  TO  THE  ASSEMBLY  LEVEL 
SUBROUTINE  OPNDEV 

CALL  OPNDEV (’ /DEV/PLOT’ , CHAN) 

HOME  THE  PLOTTER,  SET  ABSOLUTE  MODE,  SET  .005-INCH  INCREMENTS 

CALL  OUTDEV(’ ; :HA  EC5* , 8, CHAN) 

SET  THE  ORIGIN  1  INCH  IN  AND  UP  FROM  THE  HOME  POSITION 

CALL  OUTDEV (’ U  100,100  ; :0* , 13,  CHAN) 

RETURN 

END 


SUBROUTINE  CHRSIZ (HT, SIZE) 

CHRSIZE  RETURNS  THE  SIZE  OF  PLOTTED  CHARACTERS  IN  VIRTUAL  UNITS  GIVEN 
THEN  HEIGHT  IN  PLOTTER  UNITS 

ARGUMENT  TYPE  DESCRIPTION 

HT  INTEGER*4  HEIGHT  OF  CHARACTERS  IN  PLOTTER  UNITS 

SIZE  "  SIZE  OF  CHARACTERS  IN  VIRTUAL  UNITS 

INTEGER  HT, SIZE 


COMMON/ PLTVAR/  CHAN,  PSTAT ( 10) ,  SCALEX,  SCALEY 

INTEGER*4  CHAN,  PSTAT 

REAL*4  SCALEX,  SCALEY 

COMMON  BLOCK  VARIABLES 


VARIABLE 

CHAN 

PSTAT (10) 
SCALEX 


TYPE 

INTEGER*4 

INTEGER*4 

REAL*4 


DESCRIPTION 

CHANNEL  ASSIGNED  TO  PLOTTER  BY  CROMIX 
STATUS  INFORMATION  FOR  PLOTTER 
X  SCALE  :  (PLOT  UNITS/VIRTUAL  UNITS) 


PROGRAM  VARIABLES 

REAL  HEIGHT,  PUN ITS 


SINCE  THE  HOUSTON  IS  SET  TO  .005  INCHES  IN  PLINIT,  THE  CHARACTER  SIZE 
IN  INCHES  IS:  SIZE(IN)-  .  035+ (HT*. 035) 

HEIGHT®  .035+  (HT*. 035) 

PUN ITS-  HEIGHT/. 005 
SIZE-  PUNITS/SCALEY 
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RETURN 

END 


SUBROUTINE  PLREAD (STRING,  CHARS) 

PLREAD  READS  OUTPUT  FROM  THE  PLOTTER 

ARGUMENT  TYPE  DESCRIPTION 

STRING  CHARACTER  UP  TO  80  BYTES  RECEIVED  FROM  THE  PLOTTER 

CHARS  INTEGERS  NUMBER  OF  BYTES  SENT  BY  THE  PLOTTER 

CHARACTER* (*)  STRING 
INTEGER*4  CHARS 


COMMON  BLOCK  /PLTVAR/  MUST  HAVE  BEEN  INITIALIZED  BY  A  CALL  TO  SUBROUTINE 
PLINIT 

COMMON/ PLTVAR/  CHAN,  PSTAT(10),  SCALEX,  SCALEY 

INTEGER*4  CHAN,  PSTAT 

REAL*4  SCALEX,  SCALEY 

CHARACTER*99  STR, DUM 

STR=’  ’ 

OPEN (8, FILE*’ /DEV/PLOT’  ) 

CALL  OPNDEV (’  /DEV/PLOT’ , ICHAN) 

WRITE  (0,  M”  PRESS  RETURN  TO  BEGIN  DIGITIZING”)’) 

READ (0, ’ (A99) * )  STR 

CALL  OUTDEV (’  5 : EL  ED’ ,  7,  CHAN) 

ICNT=  16 

CALL  INDEV (STR, ICNT, ICHAN) 

WRITE  (8,  ’  ( ”  ;  : EL  ED”  )  ’  > 

READ (8, ’ (A99) ’ )  STR  ( 

WRITE (0, ’ (I3/A99)’ )  ICNT, STR 

WRITE  (0,  M”  PRESS  RETURN  TO  BEGIN  DIGITIZING”)’) 

READ (0, ’ (A99) * )  STR 

CALL  OUTDEV (’  ; :EL  ED’ ,  7,  CHAN) 

WRITE  (8,  ’  <”  ;  :EL  ED”  >  ’  ) 

READ (8, ’ (A99) ’ )  STR 
ICNT*  16 

CALL  INDEV (STR, ICNT, ICHAN) 

WRITE (0, ’ (I3/A99)’ )  ICNT, STR 


CLOSE (8) 

RETURN 

END 


SUBROUTINE  DELAY 
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DQ  10  1=1,30000 
X*X*1. 1+X# (-1.  1) 
10  CONTINUE 

RETURN 
END 


SUBROUTINE  PLDONE 
C 

C  PLDONE  RESETS  THE  PLOTTER  AND  CLOSES  THE  PLOT  CHANNEL 

C 

C 

C  COMMON  BLOCK  /PLTVAR/  MUST  HAVE  BEEN  INITIALIZED  BY  A  CALL  TO  SUBROUTINE 
C  PLINIT 
C 

COMMON/ PLTVAR/  CHAN,  PSTAT! 10),  SCALEX,  SCALEY 
C 

INTEGER*4  CHAN,  PSTAT 

REAL*4  SCALEX,  SCALEY 

C 
C 

C  PROGRAM  VARIABLES 
C 

CHARACTER*5  COMMND ( 1 ) 

C 

C 

C  ASSEMBLE  THE  COMMAND  TO  RESET  THE  PLOTTER 
C 

WRITE! COMMND  < 1 ) (1:5), 100) 

100  FORMAT!  *  Z  *  ) 

CALL  OUTDEV ! COMMND (1),  5,  CHAN) 

C 

C  CLOSE  THE  CHANNEL 
C 

CALL  CLSDEV(CHAN) 

C 

RETURN 

END 


SUBROUT I NE  L I NETO ! V  X , VY, L ATT ) 

C 

C  LINETO  WILL  DRAW  A  LINE  TO  THE  COORDINATES  VX,VY  WITH  LINE  ATTRIBUTES 
C  AS  SPECIFIED  IN  ARRAY  LATT 
C 

C  ARGUMENT 

C  VX 

C  VY 

C  LATT (3) 

C 
C 
C 

INTEGER*4 
C 
C 

C  COMMON  BLOCK  /PLTVAR/  MUST  HAVE  BEEN  INITIALIZED  BY  A  CALL  TO  SUBROUTINE 
C  PLINIT 
C 

COMMON/ PLTVAR/  CHAN,  PSTAT! 10),  SCALEX,  SCALEY 


TYPE 

INTEGER*4 

INTEGER*4 

INTEGER*4 


DESCRIPTION 

VIRTUAL  X  CORDINATE  OF  DRAW  DESTINATION' 


LATT ! 1 ) i 
LATT (2) i 
LATT! 3) : 


LINE  WEIGHT 
LINE  COLOR 
LINE  STYLE 


(NOT  IMPLEMENTED) 


VX,  VY,  LATT (3) 


S 


IK 


nnnnn  nonnnnn  n  n  •-  nnn  nnn  nn  nnnnnnnnnnn 


INTEGER*4  CHAN,  PSTAT 

REAL*4  SCALEX,  SCALEY 

C 

COMMON/ PLTLOC/  VXY 
C 

INTEGER*4  VXY (4) 

COMMON  BLOCK  VARIABLES 

VARIABLE  TYPE  DESCRIPTION 

VXY (4)  INTEGER*4  VXY ( 1 ) =  VLX 

VXY (2) —  VLY 
VXY (3) =  VUX 
VXY (4)  =  VUY 

PROGRAM  VARIABLES 


CHARACTER*£2  COMMND(l) 

INTEGER*4  COLOR,  STYLE,  PX,  PY 

REAL*4  RPX,  RPY 


COLOR=  LATT (£) 

STYLE=  LATT (3) 

ADJUST  ORIGIN  AND 

MULTIPLY  VX,  VY  BY  SCALE  FACTORS  TO  OBTAIN  PLOTTER  UNITS 

RPX=  FLOAT (VX-VXY ( 1 ) )  *  SCALEX 
RPY=  FLOAT (VY-VXY (£) >  *  SCALEY 
PX=  INT(RPX) 

PY=  INT (RPY) 

ASSEMBLE  COMMAND  FOR  A  MOVE  WITH  THE  PEN  DOWN 

WRITE (COMMND(l)  (1:22),  100)  COLOR,  STYLE,  PX,  PY 
i  FORMAT  (’  P',11,*  L’  ,  II, '  D  *  ,  15, '  ,’  ,  15,’  »> 

CALL  OUTDEV (COMMND ( 1 ) ,  £2, CHAN) 

RETURN 

END 


SUBROUTINE 

MOVETO (VX, VY) 

MOVETO  WILL  MOVE 

THE  PEN  TO  THE 

COORDINATES  VX,VY 

ARGUMENT 

VX 

VY 

TYPE 

INTEGER*4 

INTEGER*4 

DESCRIPTION 

VIRTUAL  X  CORD I NATE  OF  MOVE  DESTINATION 

ii  y  ii  ii  it  it 

INTEGER*4 

VX,  VY 

COMMON  BLOCK  /PLTVAR/  MUST  HAVE  BEEN  INITIALIZED  BY  A  CALL  TO  SUBROUTINE 
PLINIT 

COMMON/ PLTVAR/  CHAN,  PSTAT (10),  SCALEX,  SCALEY 
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ii 


nnnnn  nonnnnrjnnnnnnn  n  ►-  nnn  nonnn  nnnnnnnnnnn 


INTEGER*4  CHAN,  PSTAT 

REAL*4  SCALE X,  SCALEY 

C 

COMMON/PLTLOC/  VXY 
C 

INTEGER*4  VXY (4) 

COMMON  BLOCK  VARIABLES 


VARIABLE 
VXY (4) 


TYPE 

INTEG£R«4 


DESCRIPTION 
VXY ( 1 )  -  VLX 
VXY (2)-  VLY 
VXY (3)  -  VUX 
VXY (4)-  VUY 


PROGRAM  VARIABLES 

CHARACTER# IS  COMMND ( 1 ) 

INTEGER*4  PX,  PY 

REAL«4  RPX, RPX 

ADJUST  ORIGIN  AND 

MULTIPLY  VX,  VY  BY  SCALE  FACTORS  TO  OBTAIN  PLOTTER  UNITS 


RPX-  FLOAT (VX-VXY  < 1 ) )  *  SCALEX 
RPY-  FLOAT (VY-VXY  <2) )  *  SCALEY 
PX-  I NT (RPX) 

PY-  I NT (RPY) 


ASSEMBLE  THE  COMMAND  TO  MOVE  WITH  THE  PEN  UP 


WRITE (COMMND < i ) ( 1 i IS) , 100)  PX,  PY 
M  FORMAT ( *  U  IS, •,«, 15, »  ’> 

CALL  OUTDEV (COMMND ( 1 ) ,  16,  CHAN) 

RETURN 

END 


SUBROUTINE  MARKER (MID,  VX,  VY,  LATT, SCALE, ANGLE) 
MARKER  WILL  DRAW  A  MARKER  AT  COORDINATES  VX,  VY 


ARGUMENT 

TYPE 

DESCRIPTION 

MID 

.  INTEGER*4 

MARKER  TYPE  (SEE  HOUSTON  PLOTTER  DOC) 

VX 

INTEGER*4 

VIRTUAL  X  CORD I NATE  OF 

MOVE  DESTINATION 

VY 

INTEGERS 

N  y  II  N 

M  N 

LATT (3) 

INTEGER*4 

LATT ( 1 ) i  LINE  WEIGHT 

(NOT  IMPLEMENTED) 

LATT (2) :  LINE  COLOR 
LATT (3)*  LINE  STYLE 


SCALE 

REAL*4 

HEIGHT 

SPECIFIER 

ANGLE 

INTEGER*4 

MARKER 

ORIENTATION  (NOT  IMPLEMENTED) 

INTEBER*4 

MID,  VX,  VY,  LATT (3),  ANGLE 

REAL#4 

SCALE 

COMMON  BLOCK  /PLTVAR/  MUST  HAVE  BEEN  INITIALIZED  BY  A  CALL  TO  SUBROUTINE 
PLINIT 


’in 


n  n  n  n  ;*  r.  n  n  n  n  n  nnnn 


COMMON/ PLT VAR/  CHAN,  PSTAT (10),  SCALEX,  SCALEY 
C 

INTEGER*^  CHAN,  PSTAT 

REAL*4  SCALEX,  SCALEY 


PROGRAM  VARIABLES 

CHARACTER* 12  COMMND ( 1 ) 

INTEGER*4  COLOR,  STYLE,  HT 


COLOR=  LATT (2) 

STYLE=  LATT (3) 

SET  MARKER  HEIGHT 

HT  =  I NT (SCALE) 

IF  (  HT  .LE.  13  )  HT  =  1 
IF  C  HT  .GT.  5  )  HT  =5 

MOVE  TO  VX,  VY 

CALL  MOVETO (VX, VY) 

ASSEMBLE  THE  COMMAND  TO  DRAW  THE  MARKER 

WRITE  (COMMND(l)  <1:12),  1i3i3)  COLOR,  STYLE,  HT,  MID 
100  FORMAT ( 1  P’,11,’  L’,I1,»  M’ ,  1 X,  1 1 ,  1 1 ,  1 X ) 

CALL  OUTDEV (COMMND (1),  12,  CHAN) 

C 

RETURN 

END 


SUBROUTINE  PLTEXT (VX,  VY,  HT,  ANG,  STRING, NCHAR, LATT) 

i  • 


C  PLTEXT  DRAWS  TEXT  PASSED  IN  ’STRING’,  BEGINNING  AT  VX, VY  AND  AT  ANGLE  ANG 

C 


<~r 

ARGUMENT 

TYPE 

DESCRIPTION 

c 

VX 

INTEGER*4 

VIRTUAL  X  CORDINATE  OF  DRAW  DESTINATION 

c 

VY 

INTEGER*4 

ii  y  ii  >i  h  ii 

c 

HT 

INTEGER*4 

HEIGHT  OF  TEXT  IN  VIRTUAL  UNITS 

c 

ANG 

INTEGER*4 

ANGLE  OF  TEXT  (0-360) 

c 

STRING 

CHARACTER* (*) 

ARRAY  CONTAINING  TEXT 

c 

NCHAR 

INTEGER*4 

NUMBER  OF  CHARACTERS  TO  DRAW 

c 

LATT (3) 

INTEGER*4 

LATT ( 1 ) :  LINE  WEIGHT  (NOT  IMPLEMENTED) 

■Z 

LATT (2):  LINE  COLOR 

LATT (3):  LINE  STYLE 

INTEGER*4 

VX,  VY,  HT, 

ANG,  NCHAR,  LATT (3) 

CHARACTER* (*)  STRING 

COMMON  BLOCK  /PLTVAR/  MUST  HAVE  BEEN  INITIALIZED  BY  A  CALL  TO  SUBROUTINE 
PLINIT 


COMMON/ PLTVAR/  CHAN,  PSTAT <H3>,  SCALEX,  SCALEY 


integers 

REAL*4 

C 

C 

C  PROGRAM  VARIABLES 
C 

INTEGER*^ 

RPQI  *A 

CHARACTER*30 

C 

C 


CHAN,  PSTAT 
SCALE X,  SCALEY 


PH,  SX,  SY,  COLOR,  STYLE 
RADS 

COMMND < 1 ) 


COLOR=  LATT (2) 

STYLE=  LATT (3) 

RADS=  FLOAT (ANG)/57.  35 
SX  =  NINT  <  1000. *COS< RADS)  ) 

SY=  NINT (  1000. *S IN (RADS)  ) 

PH=  HT 

CALL  MOVETO (VX, VY) 

WRITE (COMMND(l) (1:30),  100)  COLOR,  STYLE, PH,SX,SY 
100  FORMAT  < ’  P’,11,*  L’ , II,*  S(S* , 15, ’ , X* , 15, ’ , Y’ , 15, » >’ 
ICNT  =  30 


CALL  OUTDEV (COMMND ( 1 ) , ICNT, CHAN) 
COLL  OUTDEV (STRING, NCHAR, CHAN) 
ICNT=  3 


CALL  OUTDEV (’_  *, ICNT, CHAN) 

RETURN 

END 


) 


SUBROUTINE  CIRCLE (VX,  VY,  VR,  LATT) 
C 


c 

p 

CIRCLE  DRAWS  0 

CIRCLE  AT  VX, 

VY  WITH  RADIUS  VR 

L. 

C 

ARGUMENT 

TYPE 

DESCRIPTION 

c 

VX 

INTEGER»4 

VIRTUAL  X 

CORD I NATE  OF  DRAW 

DESTINATION 

c 

VY 

INTEGER*4 

Y 

II  *»  *» 

M 

c 

VR 

INTEGER*3 

VIRTUAL  RADIUS  OF  CIRCLE 

c 

LOTT (3) 

INTEGER*4 

LATT ( 1 ) s 

LINE  WEIGHT  (NOT 

IMPLEMENTED) 

c 

LOTT (£> : 

LINE  COLOR 

c 

p 

LATT (3) : 

LINE  STYLE 

L 

INTEGERS 

VX,  VY, 

VR,  LATT (3) 

C 


C 

C 

c 

c 


c 

c 

c 

c 


COMMON  BLOCK  /PLTVAR/  MUST  HOVE  BEEN  INITIALIZED  BY  A  COLL  TO  SUBROUTINE 
PLINIT 

COMMON/ PLTVAR/  CHAN,  PSTAT (10),  SCALEX,  SCALEY 

INTEGER*4  CHAN,  PSTAT 

REAL  *  4  SCALEX,  SCALEY 


PROGRAM  VARIABLES 

CHARACTER*^  COMMND  ( 1 ) 

INTEGER*4  PX,  PY,  PR,  COLOR,  STYLE 


C 
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COLOR=  LATT (2) 
STYLE=  LATT (3) 


FUNCTION  I COR  RETURNS  PLOTTER  UNITS  GIVEN  A  VIRTUAL  COORDINATE  AND  SCALE 

PX=  ICOR(VX, SCALEX) 

PY=  I COR (VY, SCALEY) 

PR=  ICOR(VR, SCALEX) 

WRITE (COMMND (1) (1:£7),  100)  COLOR,  STYLE,  PX, PY, PR 
00  FORMAT (’  P’,11,’  L’ , II,’  CC» , 15, ’ , ’ , 15, IX, 15, IX) 

ICNT=  £7 

CALL  OUTDEV (COMMND ( 1 ) , ICNT, CHAN) 

RETURN 

END 


INTEGER  FUNCTION  ICOR (VU,  SCALE) 

I COR  COMPUTES  PLOTTER  UNITS  GIVEN  A  VIRTUAL  COORDINATE  AND  A  SCALE  FACTOR 

ARGUMENT  TYPE  DESCRIPTION 

VU  INTEGER*4  VIRTUAL  COORDINATE 

SCALE  REAL*4  (PLOT  UNITS) / (VIRTUAL  UNITS) 

INTEGER*4  VU 

PROGRAM  VARIABLES 
REAL  VCOR 

VCQR=  FLOAT (VU)  *  SCALE 
ICOR=*  I  NT  (VCOR) 

RETURN 

END 

SUBROUTINE  VUINCH (VUNITS) 

VUINCH  COMPUTES  THE  PLOTTER  UNITS/ INCH.  FOR  THE  HOUSTON  THERE  ARE 
£00  PLOTTER  UNITS/ INCH 

INTEGER  CHAN, PSTAT 

REAL  VUN I TS, SCALE  X , SCALEY 

COMMON  /PLTVAR/  CHAN,  PSTAT ( 10) , SCALEX, SCALEY 

VUNITS=£00. 0/SCALEX 


RETURN 

END 
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SUBROUTINE  PROCD ( ITR,  PUNIT1,  PUNIT2, PFILE1, PHFILE, SMUNIT, SMFILE) 


C**************************************************************************** 


c 

c 

c 

c 

c 

c 

c 

c 

c 

c 


THIS  SUBROUTINE  MANAGES  THE  PROCEDURE  DMA  BASE 
VARIABLES  PASSED: 


ITR 

PUN I T 1 
PUNIT2 
PFILE1 
PHFILE 
SMUNIT 
SMFILE 


INTERACTIVE  TERMINAL  READ  UNIT 

UNIT  #  TO  OPEN  THE  PROCEDURE  DIRECTORY  FILE  ON 

UNIT  #  TO  OPEN  THE  PROCEDURE  FILE  ON 

DIRECTORY  FILE  NAME 

PROCEDURE  HELP  FILE  NAME 

UNIT  #  TO  OPEN  MENU  FILE  (SMFILE)  ON 

MENU  FILE  NAME 


C**************************************************************************** 


CHARACTER* 1  CMD ( 1 ) 

CHARACTER*?  PFILE1 , PHFILE, SMFILE 

INTEGER  ITR, PUN I Tl,  PUN ITS, SMUNIT, RC(S, 3) 

C  DISPLAY  THE  MAIN  MENU  AND  INPUT  USER  SELECTION 

1  CALL  MENUSV (SMFILE,  140,  RC,  2,  SMUNIT) 

2  CMD ( 1 ) =’  » 

CALL  MENURD (RC, 2, 1, 1, CMD, ITR) 

C  CHECK  FOR  A  VALID  INPUT 

IF  (INDEX <’ 1234X’ , CMD ( 1 ) >  .  EQ.  0)  THEN 

CALL  MESS ( 1 1, RC (2, 1 ) , RC (2, 2) , RC (2, 3) , 7) 
GOTO  2 

END  IF 

C  USER  SELECTED  TO  VIEW  THE  HELP  FILES 

IF  (CMD ( 1 )  .EQ.  ’1’)  CALL  PHELP ( ITR, PUN IT 1, PHFILE, SMUNIT, SMFILE) 

C  USER  SELECTED  TO  DELETE  A  FILE  FROM  THE  EATA  BASE 

IF  (CMD ( 1 )  .EQ.  *2’)  CALL  PDEL( ITR, PUNIT1, PUNIT2, PFILE1, SMUNIT, 

*  SMFILE) 

C  USER  SELECTED  TO  ADD  TO  THE  EATA  BASE 

IF  (CMD ( I )  .EQ.  ’3’)  CALL  PADD ( ITR,  PUNIT1, PUNIT2, PFILE1, SMUNIT, 

*  SMFILE) 

C  USER  SELECTED  TO  SEARCH  THE  DATABASE 

IF  (CMD ( 1 )  .EQ.  ’  4’  )  CALL  PSEAR ( ITR, PUNIT1, PUNIT2, PFILE1, SMUNIT, 

*  SMFILE) 


C  USER  SELECTED  TO  RETURN 

IF  (CMD ( 1 )  .EQ.  ’X’)  RETURN 

GOTO  1 
END 

SUBROUTINE  PHELP (ITR,  PUNIT,  PHFILE,  SMUNIT, SMFILE) 
C**********************#*********#***#***************************************» 
C  THIS  SUBROUTINE  DISPLAYS  THE  HELP  FILE  FOR  THE  PROCEDURE  DATA  BASE 
C  VARIABLES  PASSED: 

C 

C  ITR  -  ITERACTIVE  TERMINAL  READ  UNIT 

C  PUNIT  -  UNIT  #  TO  OPEN  THE  HELP  FILE  (PHFILE)  ON 
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PHFILE  -  PROCEDURE  HELP  FILE  NAME 

SMUNIT  -  UNIT  #  TO  OPEN  MENU  FILE  (SMFILE)  ON 

SMFILE  -  MENU  FILE  NAME 

**************************************************************************** 
CHARACTER*80  TLINE, LINE 
CHARACTER*?  PHFILE, SMFILE 
CHARACTER*!  CMD(l) 


INTEGER  ITR, PUNIT, SMUNIT, RC (3, 3) 

LOGICAL  FLAG 


DISPLAY  THE  MAIN  MENU  AND  INPUT  THE  USER  SELECTION 
CALL  MENUSV (SMFILE,  145, RC,  3, SMUNIT) 

CMD ( 1 )  =*  * 

CALL  MENURD(RC, 3, 1, 1,CMD, ITR) 

CHECK  FOR  A  VALID  INPUT 

IF  (INDEX (’ 123X' ,CMD(1> )  .  EQ.  0)  THEN 

CALL  MESS ( 1 1, RC (2, 1 ) , RC (2, 2) , RC (2, 3) , 7) 
GOTO  2 

END  IF 


USER  SELECTED  TO  RETURN 
IF  (CMD  ( 1 )  .EQ.  ’X')  RETURN 

CHECK  TO  SEE  THAT  THE  HELP  FILE  EXISTS,  IF  NOT  DISPLAY  ERROR  MESSAGE 
INQUIRE  (FILE=PHFILE, EXIST=FLAG) 

IF  (.NOT.  FLAG)  THEN 

CALL  MESS (15, RC (2, 1 ) , RC (2, 2) , RC (2, 3) , 7) 

GOTO  2 
END  IF 

CLEAR  THE  SCREEN  AND  OPEN  THE  HELP  FILE 
CALL  CLEAR (7,0) 

OPEN  (PUNIT, FILE=PHFILE,  STATUS*’ OLD’ ) 

SET  UP  THE  SEARCH  KEY  FOR  THE  FILE  TO  BE  DISPLAYED. 

TLINE ( 1 :80) =’  *X*’ 

TLINE (2 i 2) “CMD ( 1 ) 

READ  IN  LINE  FROM  THE  HELP  FILE 
READ (PUNIT, ’ (A80)’ )  LINE 

C  LOOK  FOR  THE  KEY 

IF  (TLINE (1:3)  .  EQ.  LINE (1:3))  THEN 

C  DETERMINE  HOW  MANY  LINE  ARE  TO  BE  DISPLAYED 

READ (LINE (4:5),'  (12)’)  IG 
J=0 


C  START  TO  DISPLAY  THE  LINES  ON  THE  SCREEN 

DO  20  1=1, IG, 1 

READ  (PUNIT,  MA80)  ’  >  LINE 
J*J+i 

CALL  MENUDR(LINE,J,  1,2,0,  1,  1) 

C  CAN  ONLY  DISPLAY  22  LINES  ON  THE  SCREEN  AT  ONCE 

IF  (J  .EQ.  22)  THEN 
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C  END-OF-FILE  REACHED  DISPLAY  MESSAGE 

IF  (I  .EQ.  IG)  THEN 

CALL  MESS (19, RC<3, 1 ) , RC (3, 2) , RC (3, 3) , 7) 
READ < ITR, ’  (A1 ) ’ )  CMD(1> 

CLOSE  (PUNIT) 

GOTO  1 

ELSE 


C 
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MORE  TO  BE  DISPLAY  (PRESS  RETURN  TO  CONTINUE) 
CALL  MESS ( 16, RC (3, 1 ) , RC (3, 2) , RC (3, 3> , 7) 

READ (ITR,’  <A1)’ >  CMD(l) 

CALL  CLEAR (7,0) 

J=0 

END  IF 

END  IF 


CONTINUE 


C  END-OF-FILE  REACHED 

CALL  MESS ( 19,  RC (3, 1 ) , RC (3, 2) , RC (3, 3) , 7) 
READ ( ITR,  '  <A1)’ )  CMD ( 1 ) 

CLOSE  (PUNIT) 

GOTO  1 

ENDIF 


GOTO  5 
END 

SUBROUTINE  PADD ( ITR,  PUNIT1,  PUNIT2, PFILE1 , SMUNIT, SMFILE) 

C**************************************************************************** 
THIS  SUBROUTINE  ADDS  ENTRIES  TO  THE  PROCEDURE  DATA  BASE.  THERE  IS  A  FILE 
THAT  CONTAINS  A  LIST  OF  ALL  THE  FILES  ON  THE  SYSTEM  AND  NAME  OF  THE 
PROCEDURES  ASSOCIATED  WITH  THOSE  FILES 
VARIABLES  PASSED: 


ITR 

PUNIT1 

PUNIT2 

PFILE1 

SMUNIT 

SMFILE 


INTERACTIVE  TERMINAL  READ  UNIT 
UNIT  #  TO  OPEN  PFILE1  ON 
UNIT  #  TO  OPEN  THE  PROCEDURE  FILE  ON 
DIRECTORY  FILE  NAME 

UNIT  #  TO  OPEN  MENU  FILE  (SMFILE)  ON 
MENU  FILE  NAME 


C**************************************************************************** 


CHARACTER*80 

CHARACTER*40 

CHARACTER*7 

CHARACTER*! 


LINE 

PKEY ( 1 ) , CIN, TEXT (2) 

PFILE1, EFILE, SMFILE, PFILE2 
CMD ( 1 ) 


INTEGER  ITR,  PUNIT1,  PUNIT2,  SMUNIT, RC(5, 3), ST (3) 

LOG I CAL  FLAG 1, FLAG2 

DATA  ST/0,0,0/ 

ITT=-1 

PKEY(l) (1:40)=’  ' 

TEXT (1) (1:40) -’ENTER  "ABORT//"  TO  ABORT  THE  FILE' 
TEXT (2) (1:40) -’ENTER  "END//"  TO  SAVE  THE  FILE’ 
FLAG2-. FALSE. 


~  n  o»  n 


U  DISPLAY  THE  MAIN  MENU 

100  CALL  MENUSV  < SMF I LE,  146,  RC,  5,  SMUNIT) 

IF  (FLAGS)  THEN 

ST (3) *0 

IF  (PKEY(l)  .NE.  *  ’> 

*  CALL  MENUWR (RC, 5, 1, 1, PKEY, 0, 1, ST) 

GOTO  15 
END  IF 

INPUT  THE  PROCEDURE  FILE  NAME 
CALL  MENURD (RC,  5,  1,  1,  PKEY,  ITR) 

FLAGS  =. FALSE. 

SCANNING  THE  COMMAND  INPUT  LINE 
CMD  ( 1  >  =**  * 

CALL  MENURD (RC,  5,  3,  S,  CMD,  ITT) 

C  USER  SELECTED  TO  GO  BACK  TO  THE  PROCEDURE  INPUT  LINE 
IF  (CMD ( 1 )  .EQ.  ’  *>  THEN 

ST(3>*1 

CALL  MENUWR ( RC,  5, 3,  3, CMD, 0, 1 , ST) 

CALL  MESS (4,  RC (5, 1 ) , RC (5, 3) , RC (5, 3) , 1) 

GOTO  5 
END  IF 

C  USER  SELECTED  TO  RETURN 

IF  (CMD ( 1 )  .EQ.  ’X’)  RETURN 

C  INVALID  INPUT 

IF  (CMD ( 1 )  .NE.  *C’)  GOTO  15 

C  A  BLANK  PROCEDURE  NAME  IS  NOT  ALLOWED 
IF  ( PKEY ( 1 )  .EQ.  ’  *)  THEN 

CALL  MESS (30, RC (5, 1 > , RC (5, 3) , RC (5, 3) , 7) 
GOTO  15 
END  IF 

C  CHECK  IF  THE  DIRECTORY  FILE  EXISTS 

I NQU IRE  (FILE-PFILE1,  EXI ST*FL AG  1 ) 

C  CREATE  THE  DIRECTORY  FILE 

IF  (.NOT.  FLAG1 )  THEN 

OPEN  (PUNIT1,  FILE*PFILE1,  STATUS®' NEW’ , FORM*’ UNFORMATTED’ , 

*  ACCESS*’ DIRECT’ ,  RECL=48) 

NREC*1 

C  WRITE  THE  HEADER  RECORD 

WRITE (PUNIT1, REC*1)  NREC 
WRITE (PUNIT1, REC*3)  NREC 
CLOSE  ( PUN 1 T 1 ) 

END  IF 

C  CHECK  TO  SEE  IF  THE  PROCEDURE  IS  ALREADY  IN  THE  DATA  BASE 
OPEN  (PUNIT1, FILE=PFILE1,  STATUS*’ OLD* ,  ACCESS-’ DIRECT’ , 

«  FORM*’ UNFORMATTED’  , RECL=48> 

C  FIND  OUT  HOW  MANY  FILES  ARE  ALREADY  IN  THE  DATA  BASE 
READ(PUNIT1, R£C=1)  NREC 
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C  CHECK  TO  SEE  IF  THE  PROCEDURE  ALREADY  EXISTS 
DO  20  I=2,NREC, 1 

READ (PUNIT1, REC=I )  CIN 

PROCEDURE  FOUND 
IF  (CIN  .EQ.  PKEY ( 1 ) )  THEN 

CALL  MESS <2, RC(5, 1 ) , RC <5, 2) , RC (5, 3) , 7) 

CLOSE  (PUNIT1 ) 

GOTO  15 
END  IF 

CONTINUE 

FIND  THE  PROC  FILE  THAT  IS  TO  BE  USED.  THE  FORM  WILL  BE  PROCXX,  WHERE 
XX  =0,  1,2, ...  ,99 
DO  25  I =0, 99, 1 

PF I LE2=EF I LE ( I ) 

PFILE2(1 :4) =’  PROC’ 

I NQU IRE  <  F I LE= PF I LE2 , E X I ST=FL AG 1 ) 

IF  (.NOT.  FLAG1)  GOTO  30 
CONTINUE 

TO  MANY  FILES  EXIST 

CALL  MESS (21,  RC (5,  1 ) ,  RC (5,  2) ,  RC (5, 3) , 7) 

GOTO  15 

C  DISPLAY  THE  DIRECTION  ABOUT  END  AND  ABORT 

30  ST (3) =1 

CALL  MENUWR ( RC, 5,  3, 4, TEXT, 0, 1 ,  ST ) 

C  INPUT  THE  USERS  OPTION 

CMD(l)®’  * 

CALL  MENURD (RC, 5, 2, 2, CMD, ITT) 

C  USER  SELECTED  RETURN 

IF  (CMD ( 1 )  .EQ.  ’X’)  THEN 

CLOSE  (PUNIT1) 

RETURN 
END  IF 

C  OPEN  THE  PROCEDURE  FILE,  THE  USER  IS  GOING  TO  CREATE 
OPEN  (PUNIT2, FILE=PFILE2, STATUS®’ NEW’ ) 

»  s 

C  CLEAR  THE  SCCREEN  AND  TURN  THE  CURSOR  ON 
CALL  CLEAR (7,0) 
o  CALL  ONOFF ( 1 ) 

C  READ  THE  USERS  LINE  OF  TEXT 

35  READ ( ITR, * (A80) ’ )  LINE 

C  USER  DECIDED  NOT  TO  SAVE  THE  PROCEDURE  FILE 
IF  (LINE  .EQ.  ’ABORT//’)  THEN 

CLOSE  (PUNIT1 ) 

CLOSE  (PUNIT2, STATUS®’ DELETE*  > 

FLAG2-. TRUE. 

CALL  ONOFF (0) 

GOTO  100 
END  IF 

C  USER  WANTS  TO  SAVE  THE  PROCEDURE  FILE 
IF  (LINE  .EQ.  ’END//’)  THEN 
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CLOSE  (PUNIT2) 

NREC=NREC+1 

WR I TE ( PUN I T 1 , REC=NREC )  PKEY, PF I LEE 
I I I=NREC+1 

WRITE ( PUNIT1, REC=I I I )  PKEY, PFILE2 
WRITE ( PUNIT1, REC™1 )  NREC 
CLOSE  (PUNIT1) 

CALL  ONOFF (0) 

PKEY(l) (1:40)=’  » 

FLAGS*. TRUE. 

GOTO  100 
END  IF 

C  WRITE  THE  LINE  TO  THE  PROCEDURE  FILE  PROCXX 
WRITE (PUNIT2, ’ (A80) M  LINE 
GOTO  35 


END 

SUBROUTINE  PSEAR ( ITR,  PUNIT1 ,  PUNIT2, PFILE1, SMUNIT, SMFILE) 


C**************************************************************************** 
THIS  SUBROUTINE  SEARCHES  THE  PROCEDURE  DATA  BASE  AND  WILL  DISPLAY  THE  FILE 
THAT  THE  USER  SELECTS 
VARIABLES  PASSED: 


ITR 

PUNIT1 
PUN ITS 
PFILE1 
SMUNIT 
SMFILE 


INTERACTIVE  TERMINAL  READ  UNIT 

UNIT  #  TO  OPEN  PFILE1  ON 

UNIT  #  TO  OPEN  PROCEDURE  FILE  ON 

PROCEDURE  DIRECTORY  FILE 

UNIT  #  TO  OPEN  MENU  FILE  (SMFILE)  ON 

MENU  FILE  NAME 


C*****************************************************««*##*##***********»***4 


CHARACTER*70 

CHARACTER**© 

CHARACTER*? 

CHARACTER*2 


OUT (19) 

PKEY 

PFILE1, PFILES, EFILE, SMFILE 
CMD ( 1 ) , TEMP 


LOG I CAL  FL AG 1 ,  FL AGE ,  FLAG3 

INTEGER  ITR, JJ, CNT, PUNIT1, PUNIT2, RC<£0, 3) , SMUNIT, NREC, ST (3) 


DATA  ST/0,0,0/ 

C  DISPLAY  THE  MAIN  MENU 

100  CALL  MENUSV (SMFILE,  1*7,  RC,  20, SMUNIT) 

C  CHECK  TO  SEE  THAT  THE  PROCEDURE  DATA  BASE  EXISTS 
I NQU IRE  ( F I LE=PF I LE 1 ,  EX  I ST-FL AG 1 ) 


C  PROCEDURE  DIRECTORY  FILE  NOT  FOUND 
IF  (.NOT.  FLAG1 )  THEN 

CALL  MESS ( IB, RC (20, 1 > , RC (£0, E) , RC (20, 3) , 7) 
5  CMD ( 1 ) =’  * 

CALL  MENURD (RC, 20, 1,1, CMD,  ITR) 

IF  (CMD  ( 1 )  .EO.  ’X  »)  RETURN 
GOTO  5 
END  IF 


C  OPEN  THE  PROCEDURE  DIRECTORY  FILE 

OPEN  ( PUN I T 1 , F I LE-PF I LE 1 , STATUS-' OLD’ , ACCESS-*  D I RECT’ , 

#  FORM-’ UNFORMATTED’ ,  RECL-48) 

C  FOUND  OUT  HOW  MANY  RECORS  ARE  IN  THE  FILE 

'  READ (PUNITi, REC-1 )  NREC 

FLAG 1-. TRUE. 

FLAG2-.  TRUE. 

15  CNT-2 

C  PROCESS  THE  DIRECTORY  FILE  AND  GET  THE  PROCEDURE  NAMES 
DO  20  1=2, NREC, 1 

READ ( PUN I T 1 , REC= I )  PKEY, PF I LE2 
FLAG2-. FALSE. 

>  FLAG1-.  FALSE. 

OUT <CNT) (1:70)=’  ’ 

WRITE (OUT (CNT) (2:3),’  <I2)’ )  I 
)  OUT (CNT) (6: 70) -PKEY 

C  CAN  ONLY  DISPLAY  19  PROCEDURE  NAMES  ON  THE  SCREEN  AT  A  TIME 

*“>  IF  (CNT  .EQ.  19)  THEN 

CALL  MENUWR(RC, 20,2, 19, OUT, 0, 1,ST> 

INPUT  THE  USER  SELECTION 
CMD ( 1 ) =*  ’ 

CALL  MENURD (RC,  20, 1,  1, CMD, ITR) 

USER  SELECTED  TO  RETURN 
IF  (CMD ( 1 )  .EQ.  ’X  ’>  THEN 

CLOSE  (PUNITI) 

RETURN 
END  IF 

USER  SELECTED  TO  CONTINUE  VIEWING  THE  LIST 
IF  (CMD ( 1 )  .EQ.  ’C  ’)  THEN 

FLAG 1=. TRUE. 

CALL  MENUSV (SMFILE, 147, RC, 20, SMUNIT) 

CNT-2 
GOTO  20 
ENDIF 

VALIDATE  THE  USERS  INPUT 
READ (CMD ( 1 > ,  ’  (BN, 12) * , ERR-45)  JJ 
IF  ((JJ  .LE.  1).0R. (JJ  .GT.  NREC))  GOTO  45 
READ (PUNITI, REC-JJ)  PKEY, PFILE2 
INQUIRE  (FILE-PFILE2, EXIST-FLAG3) 

IF  (.NOT.  FLAG3)  GOTO  45 

C  USER  SELECTED  A  VALID  PROCEDURE  FILE  NUMBER  SO  DISPLAY  THE  FILE 

CLOSE  (PUNITI) 

CALL  PROPRO( ITR,  PFILE2,  PUNITI) 

GOTO  100 

ENDIF 

CNT-CNT+1 
20  CONTINUE 

IF  ( (FLAG 1). AND. (.NOT.  FLAG2) )  GOTO  15 
IF  ( (FLAG1 > . AND. (FLAG2) ) 

•  CALL  MESS (22, RC (20,  1 > ,  RC (20, 2) , RC (20,  3) ,  7) 
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READ(PUNIT1,  REC*I)  PKEY,  PFILES 
FLAGS*. FALSE. 

FLAG 1*. FALSE. 

OUT (CNT) (1:70)='  ’ 

WRITE (OUT (CNT) (2:3),’  ( 12) ’ )  I 
OUT (CNT) (6:70) =PKEY 
IF  (ISTART  .EQ.  -1)  ISTART=I 
I END* I 

C  CAN  DISPLAY  ONLY  19  AT  A  TIME  ON  THE  SCREEN 

IF  (CNT  .EQ.  19)  THEN 

CALL  MENUWR ( RC,  20,  2,  19,  OUT, 0, 1,ST) 

C  INPUT  THE  USERS  SELECTION 

45  CMD(l) (1:18)=’  ’ 

CALL  MENURD(RC,  20,  1,1,  CMD, ITR) 

C  USER  SELECTED  TO  RETURN 

IF  (CMD ( 1 )  .EQ.  ’X’)  THEN 

CALL  PCOMP (PUNIT1,  PFILE1 > 

CLOSE  ( PUNIT1 ) 

RETURN 
END  IF 

C  USER  SELECTED  TO  CONTINUE  VIEWING  THE  LIST 

IF  (CMD  ( 1 )  .EQ.  ’CM  THEN 

ISTART— 1 
FLAG 1*.  TRUE. 

CALL  MENUSV (SMFILE, 148, RC, 20, SMUNIT) 

CNT-2 

GOTO  20 

END  IF 

C  DELETE  THE  FILES  FROM  THE  PROCEDURE  DIRECTORY 

INP=CMD  < 1 ) 

CALL  PROPDE(PUNITl,  PFILE1, INP, ISTART, I END) 

GOTO  45 

ENDIF 

CNT =CNT  + 1 
20  CONTINUE 

IF  (( FLAG 1). AND. (.NOT.  FLAG2) )  THEN 

CALL  PCOMP (PUNIT1, PFILE1) 

GOTO  15 
ENDIF 

IF  (( FLAG 1 >. AND. (FLAG2) ) 

*  CALL  MESS (22,  RC (20,  1 ) ,  RC (20,  2) ,  RC (20, 3) , 7) 

CALL  MENUWR (RC, 20,  2,  CNT-1,  OUT, 0, 1 , ST) 

C  INPUT  THE  USER  SELECTION 

35  CMD(l) (1:18)*’  * 

CALL  MENURD(RC,  20,  1,1,  CMD, ITR) 

C  USER  SELECTED  TO  RETURN 

IF  (CMD ( 1 )  .EQ.  ’X’>  THEN 

CALL  PCOMP (PUNIT1, PFILE1) 

CLOSE  (PUNIT1) 

RETURN 

ENDIF 
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C  NOT  19  PROCEDURE  FILES  TO  DISPLAY 

CALL  MENUWR (RC, SO, 2, CNT-1, OUT, 0, 1,ST> 

C  INPUT  THE  USERS  SELECTION 

35  CMD ( 1 )  =’  1 

CALL  MENURD ( RC, 20, 1,1, CMD, ITR) 

C  USER  SELECTED  TO  RETURN 

IF  (CMD ( 1  >  .EQ.  'X  ’)  THEN 

CLOSE  (PUNIT1) 

RETURN 
END  IF 

USER  SELECTED  TO  CONTINUE  VIEWING  LIST 
IF  (CMD ( 1 )  .EQ.  »C  ’  )  THEN 

FLAG1-. TRUE. 

CALL  MENUSV ( SMF I LE , 147,  RC, 20,  SMUNIT) 

GOTO  15 
END  IF 

CHECK  THAT  THE  USER  SELECTED  A  VALID  PROCEDURE  FILE 
READ (CMD ( 1 ) ,  ’  (BN,  12)  ’ ,  ERR=35)  JJ 
IF  ((JJ  .LE.  l).OR.  (JJ  .GT.  NREC) )  GOTO  35 
READ ( PUN I T 1 ,  REC= J J )  PKEY, PF I LE2 
INQUIRE  (FILE=PFILE2, EXIST=FLAG3) 

IF  (.NOT.  FLAG3)  GOTO  35 

C  USER  SELECTED  A  VALID  PROCEDURE  FILE 

CLOSE  ( PUN I T 1 ) 

CALL  PROPRO ( ITR,  PFILE2, PUNIT1 ) 

GOTO  100 

END 

SUBROUTINE  PROPRO (ITR, PFILE, PUNIT) 

C***************************************************************************** 
C  THIS  SUBROUTINE  PROCESS  THE  PROCEDURE  FILE.  IT  DISPLAYS  THE  FILE  ON  THE 
>  C  SCREEN  23  LINES  AT  A  TIME 

C  VARIABLES  PASSED: 

C 

-V  C  ITR  -  INTERACTIVE  TERMINAL  READ  UNIT 

C  PUNIT  -  UNIT  tt  TO  OPEN  THE  PROCEDURE  FILE  (PFILE)  ON 

C  PFILE  -  PROCEDURE  FILE  NAME  TO  DISPLAY 

Q  C***************************************************************************** 

CHA  R ACTE  R*80  DLINE 
)  CHARACTER*?  PFILE 

CHARACTER* 1  I NP ( 1 ) , FMFEED 

INTEGER  PUNIT,  RC( 1,3) 

LOGICAL  FLAG 1,1 FLAG 

RC(1, l)-23 
RC (1, 2) *34 
RC  ( 1 , 3  >  =  1 

C  CLEAR  THE  SCREEN  AND  OPEN  THE  PROCEDURE  FILE  PROCXX 
CALL  CLEAR (7,0) 


C 

n 

c 
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OPEN  (PUNIT, FILE=PFILE, STATUS=’ OLD’ ) 


IFLAG=. FALSE. 

30  FLAG1=.  TRUE. 

C  DISPLAY  22  LINES  OF  TEXT  ON  THE  SCREEN 
DO  10  1=1,22,1 

READ  (PUNIT,  MA80)’  ,END=15>  DLINE 
IF  (FLAG1)  THEN 

FLAG1=. FALSE. 

CALL  CLEAR <7, 0) 

END  IF 

CALL  MENUDR (DLINE,  I,  1,  2, 0, 1, 1) 

10  CONTINUE 

GOTO  16 

15  IFLAG=. TRUE. 

16  IF  ( I  FLAG)  CALL  MENUDR  ( ’  END  OF  FILE  REACHED’ ,  23,  62,  7,  0,  1,  1) 
CALL  MENUDR  (’SELECT  OPTION  (X  OR  C  OR  P)  ==>*,23,1,2,0,1,1) 

M  C  INPUT  USERS  SELECTION 
20  INP ( 1 >  =’  ’ 

CALL  MENURD(RC, 1,  1,  1,  INP,  ITR> 

C  USER  SELECTED  TO  RETURN 

IF  ( INP  ( 1 )  .EQ.  ’X’>  THEN 

CLOSE  (PUNIT) 

RETURN 
END  IF 

USER  SELECTED  TO  PRINT  THE  PROCEDURE  FILE 
IF  ( INP ( 1 )  .EQ.  ’PM  THEN 

CLOSE (PUNIT) 

OPEN (PUNIT, FILE=PFILE, STATUS®* OLD* ) 

IF=  12 

FMFEED=  CHAR (IF) 

OPEN  THE  PRINTER  ON  UNIT  15 
OPEN ( 15, FILE®’ /DEV/PRT’ ) 

READ (PUNIT, ’ (A80) ’ , END=220)  DLINE 
CONTINUE 
SEND  FORM  FEED 

WRITE (15, * (Al)’ )  FMFEED 
DO  210  1=1,22 

READ (PUNIT, *  (A80) ’ , END=220)  DLINE 
WRITE ( 15, ’ (A80)’ )  DLINE 
CONTINUE 
GO  TO  200 

CONTINUE 

WRITE(15, ’ (Ai) ’ )  FMFEED 
CLOSE (PUNIT) 

CLOSE (15) 

RETURN 
ENDIF 

C  USER  SELECTED  TO  CONTINUE  VIEWING  THE  PROCEDURE  FILE 
IF  (INP ( 1  >  .EQ.  ’CM  THEN 

IF  (I FLAG)  THEN 

I FLAG*. FALSE. 

CLOSE  (PUNIT) 
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OPEN  (PUNIT, FILE=PFILE, STATUS*’ OLD’  ) 

END  IF 

GOTO  30 
END  IF 

GOTO  20 
END 

SUBROUTINE  PDELdTR,  PUNIT1,  PUNIT2,  PFILE1, SMUNIT, SMFILE) 

C****************************************************************************** 
THIS  SUBROUTINE  DELETES  PROCEDURE  FILES  FROM  THE  PROCEDURE  DIRECTORY  FILE 
ONLY 

VARIABLES  PASSED: 

ITR  -  INTERACTIVE  TERMINAL  READ  UNIT 

PUNIT1  -  UNIT  #  TO  OPEN  LISTING  FILE  (PFILE1)  ON 

PUNIT2  -  UNIT  #  TO  OPEN  PROCEDURE  FILE  ON 

PFILE1  -  PROCEDURE  LISTING  FILE  NAME 

SMUNIT  -  UNIT  #  TO  OPEN  MENU  FILE  (SMFILE)  ON 

SMFILE  -  MENU  FILE  NAME 

C****************************************************************************** 

CHARACTER*70  OUT (19) 

CHA  RACTER*40  PKEY 

CHARACTER* 18  CMD ( 1 ) , INP 

CHARACTER*?  PFILE1,  PFILE2,  EFILE, SMFILE 

INTEGER  ITR,  JJ,  CNT,  PUNIT1,  PUNIT2, ISTART, IEND, ST (3) , RC (20, 3) 

LOGICAL  FLAG1,  FLAG2, FLAG3 

DATA  ST/0,0,0/ 

C  DISPLAY  THE  MAIN  MENU 

CALL  MENUSV (SMFILE, 148,  RC,  20,  SMUNIT) 

C  CHECK  TO  SEE  THAT  THE  PROCEDURE  DATABASE  EXISTS 
INQUIRE  (FILE-PFILE1,EXIST=FLAG1> 

C  NO  PROCEDURE  DIRECTORY  FILE,  DISPLAY  A  MESSAGE 
IF  (.NOT.  FLAG1 )  THEN 

CALL  MESS  ( 18,  RC  (20,  1 ) ,  RC  (20,  2) ,  RC  (20,  3) ,  7) 

5  CMD  (1)  (1:18)=*’  ’ 

CALL  MENURD(RC, 20, 1,1,  CMD,  ITR) 

IF  (CMD  ( 1 )  .EQ.  ’X’)  RETURN 
GOTO  5 
END  IF 

« 

C  OPEN  THE  PROCEDURE  DIRECTORY  FILE 

OPEN  (PUNIT1, FILE-PFILE1,  STATUS8*’  OLD’ ,  ACCESS*’ DIRECT’ , 

*  FORM*’ UNFORMATTED’ ,  RECL-48) 

C  FIND  OUT  HOW  MANY  RECORDS  ARE  IN  IT 
15  READ(PUNIT1, REC=1 )  NREC 

ISTART—1 
FLAG1-. TRUE. 

FLAG2*. TRUE. 

CNT=2 

C  DISPLAY  THE  PROCEDURE  FILES  ON  THE  SCREEN 
DO  20  1-2, NREC,  1 
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C  USER  SELECTED  TO  CONTINUE  VIEWING  THE  LIST 
IF  (CMD  (1)  .  EQ.  ’CM  THEN 

CALL  PC0MP(PUNIT1, PFILE1) 

CALL  MENUS V (SMFILE, 148, RC, 20, SMUNIT) 

GOTO  15 
END  IF 

C  DELETE  AND  COMPRESS  THE  PROCEDURE  DIRECTORY  FILE 
INP-CMD(l) 

CALL  PROPDE (PUNIT1,  PFILE1,  INP,  ISTART, I END) 

GOTO  35 

END 

SUBROUTINE  PROPDE (PUNIT1,  PFILE1,L, ISTART, I END) 

C****************************************************************************** 
THIS  PROCEDURE  DELETES  THE  PROCEDURE  FILE  NAME  FROM  THE  DIRECTORY  AND 
COMPRESS  THE  FILE 
VARIBLES  PASSED: 


PUNIT1 

PFILE1 

L 

ISTART 
I  END 


UNIT  #  TO  OPEN  THE  PROCEDURE  DIRECTORY  FILE  ON 

PROCEDURE  DIRECTORY  FILE  NAME 

LIST  OF  THE  FILES  TO  BE  DELETEED 

STARTING  FILE  NUMBER 

ENDING  FILE  NUMBER 


C*********«**************************»*********»******************«#*******«-*** 


CHARACTER*48  XOUT 
CHARACTER* 18  L 
CHARACTER*8  FMT 
CHARACTER*?  PFILE1 
CHARACTER* 1  Cl 

INTEGER  PUNIT1,  CNT,  iS,  ST,  P0S(8) , IL, ISTART, I END 


XOUT-’ XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX’ 
FMT*’  (BN, I XX)’ 

CNT*  l 
ST*1 

DO  100  1*1, 18, 1 

IF  (ST  .EQ.  1)  THEN 

II “INDEX (’01 23456789  ’,L(IsI>) 

IF  (II  .EQ.  11)  GOTO  100 
IF  (II  .EQ.  0)  THEN 

CALL  MENUDR  (’  INVALID’  ,  1,55,7,0,  1,  1) 
CALL  MENUDR  (L,  1,63,  2,0,  1,  1) 
C1=L(I:I> 

CALL  MENUDR(C1,  1,62+1,7,0,  1,  1) 
RETURN 


END  IF 

JS*I 

ST*2 

GOTO  100 
END  IF 

IF  (ST  .EQ.  2)  THEN 

I 1*INDEX(’ 0123456789  ,’,L(I:I)> 

IF  (II  .EQ.  0)  THEN 

CALL  MENUDR ( ’  INVALID’,  1,55,7,0,  1,  1) 
CALL  MENUDR  (L,  1,63,2,0,  1,  1) 
C1-L(I«I) 


126 


nnnn 


CALL  MENUDR (Cl,  1, 62+1,  7,  0,  1,  1 ) 

RETURN 

END  IF 

IF  (II  .NE.  12)  GOTO  10® 

IL=I-JS 

IF  (IL  .GE.  1®>  THEN 
WRITE(FMT (6:7) ,  50)  IL 
50  FORMAT (12) 

ELSE 

FMT (7:7)=’  * 

WRITE (FMT (6:6) , 55)  IL 
55  FORMAT  (ID 

END  IF 

READ (L(JS:I-1), FMT)  POS(CNT) 

CNT=CNT+1 
ST =3 

GOTO  100 
END  IF 

IF  (ST  .EQ.  3)  THEN 

I1=INDEX(’ 0123456789  *tL(IsI)) 

IF  (II  .EQ.  11)  GOTO  100 

IF  (II  .EQ.  0)  THEN 

CALL  MENUDR  (*  INVALID’ ,  1, 55,  7,  0,  1,1) 

CALL  MENUDR  (L,  1, 63,2,0,  1,  1) 

C1=L(I:I) 

CALL  MENUDR(C1,  1,62+1,7,0,  1,1) 

RETURN 

ENDIF. 

JS=I 

ST=2 

ENDIF 

100  CONTINUE 

IF  (ST  .EO.  2)  THEN 

IL=I-JS 

IF  (IL  .GE.  10)  THEN 

WRITE (FMT (6:7), 50)  IL 
ELSE 

FMT (7:7) =’  * 

WRITE (FMT (6 : 6) , 55)  IL 
ENDIF 

READ (L ( JS: IB) ,  FMT)  POS(CNT) 

ENDIF 

DO  150  1=1, CNT, 1 

IF  ((POS(I)  .LT.  I START) . OR. ( POS ( I )  .GT.  IEND) )  GOTO  150 
I 1=6+P0S ( I ) -ISTART 

CALL  MENUDR ( *  DELETED’  , 1 1 , 55, 7, 0, 1 , 1 ) 

WRITE(PUNIT1, REC=PQS ( I ) )  XOUT 
150  CONTINUE 

RETURN 

END 

SUBROUTINE  PCOMP (PUNIT, PFILE) 

C************#********#*»******#***********#****#*#***#********«*****«********* 
THIS  SUBROUTINE  COMPRESSES  THE  PROCEDURE  LIST  FILE 
VARIABLES  PASSED: 

PUNIT  -  UNIT  «  PFILE  IS  OPEN  ON 
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C  PFILE  -  NOT  USED 

C**************************************************************************** 

CHARACTER*48  LINEIN, XOUT 
CHARACTER*?  PFILE 

INTEGER  PUN IT, NREC, I 

XOUT=*  XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX’ 

C  FIND  GUT  HOW  MANY  RECORDS  ARE  IN  THE  FILE 
)  READ ( PUN IT,  REC- 1 >  NREC 

1=2 

/  C  UPDATE  THE  HEADER  RECORD  TO  REFLECT  THE  COMPRESSION 
100  IF  (I  .GT.  NREC)  THEN 

WRITE(PUNIT, REC=1)  NREC 

RETURN 

END  IF 

C  INPUT  THE  PROCEDURE  FILE  NAME 
READ ( PUN I T, REC= I )  LINEIN 

IF  IT  IS  ALL  X’S  THEN  MOVE  THE  FILE  DOWN  ONE 
IF  (LINEIN  .EQ.  XOUT)  THEN 

DO  200  J=I , NREC-1 , 1 

READ(PUNIT, REC=J+1)  LINEIN 
WRITE (PUNIT, REC=J)  LINEIN 
CONTINUE 
NREC=NREC-1 
GOTO  100 
END  IF 

1  =  1+1 
GOTO  100 

END 


o 
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♦bigcode 

♦segment  Xssdbseg 

SUBROUTINE  SSSIP(ITR,  SUNIT1 ,  SUNITE,  SUNIT3,  SUNIT4,  SFILE1, 

*  SFILE2, SFILE3, SFILE4, SHFILE, SMUNIT, 

*  SMFILE) 

C  THIS  SUBROUTINE  MANAGES  THE  SUBSTANCE-SOURCE  DATA  BASE 


CHARACTER* 1  OPT , CMD ( 1 ) 

CHARACTER*?  SFILEl,  SFILE2,  SFILE3,  SFILE4, SHFILE, SMFILE 
CHARACTER*40  SKEV ( £ ) 


REAL 


SDATA (14) 


INTEGER  ITR,  ef lag,  SUNIT1,  SUNITS, SUNIT3, SUNIT4, SMUNIT, 

*  RC  (2,  3) 


1  CALL  MENUSV ( SMF I LE ,  1 70,  RC ,  2 ,  SMUN I T  > 

2  CMD ( 1 )  =’  » 

CALL  MENURD(RC,  2, 1,  1,CMD, ITR) 


C  CHECK  FOR  A  VALID  INPUT 

IF  (INDEX (’ 12345X’ ,CMD<1) )  .EQ.  0)  THEN 

CALL  MESS ( 1 1 , RC (2, 1 ) , RC (2, 2) , RC (2, 3) , 6) 
GOTO  2 

END  IF 


OPT 

—i  i 

IF 

(CMD ( 1 ) 

IF 

(CMD ( 1 ) 

* 

* 

IF 

(CMD ( 1 ) 

* 

* 

IF 

(CMD ( 1 ) 

* 

« 

IF 

(CMD ( 1 ) 

* 

« 

IF 

(CMD ( 1 ) 

.  EQ. 
-EQ. 


.EQ. 


.EQ. 


.EQ. 


.EQ. 


’  1*  ) 
’  2’  ) 

’3’  > 

’4*  ) 

’5’  > 

’  X’  ) 


CALL  SHELP (ITR, SUNIT1, SHFILE, SMUNIT, SMFILE) 

CALL  SDEL (ITR, SUNIT1, SUNIT2, SUNIT3, SUNIT4, 
SFILEl, SFILE2, SFILE3, SFILE4, SMUNIT, 
SMFILE) 

CALL  SADD (ITR, SUN I T 1 , SUN I T2, BUN I T3, SUN I T4, 
SFILEl, SFILE2, SFILE3, SFILE4, SMUNIT, 
SMFILE) 

CALL  SMOD ( ITR, SUNIT1 , SUNIT2, SUNIT3, SUNIT4, 
SFILEl, SFILE2, SFILE3, SFILE4, SMUNIT, 
SMFILE) 

CALL  SSEAR(EFLAG, ITR, SUNIT1, SUNIT2, SUNIT3, 

SUNIT4, OPT, SKEY, SDATA, SFILEl, SFILE2, 
SFILE3, SFILE4, SMUNIT, SMFILE) 

RETURN 


GOTO  1 
END 

SUBROUTINE  SHELP ( ITR,  SUN IT,  SHFILE,  SMUNIT, SMFILE) 


CHARACTER*80  TLINE, LINE 
CHARACTER*?  SHFILE, SMFILE 
CHARACTER*!  CMD(l) 


INTEGER  ITR,  SUNIT,  SMUNIT, RC<3, 3) 

LOGICAL  FLAG 


1  CALL  MENUSV (SMFILE,  175, RC, 3, SMUNIT) 

2  CMD  ( 1  >  *’  ’ 

CALL  MENURD (RC, 3, 1, 1, CMD, ITR) 

C  CHECK  FOR  A  VALID  INPUT 
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IF  (INDEX (’ 1234X’ ,CMD(1) )  .  EQ.  0)  THEN 

CALL  MESS(11, RC(2,  1 ) ,  RC  (£,  2) ,  RC  (2,  3) ,  6) 
GOTO  2 

END  IF 


IF  (CMD(l)  .EQ.  ’X’)  RETURN 
INQUIRE  (FILE=SHFILE,  EXIST=FLAG) 

IF  (.NOT.  FLAG)  THEN 

CALL  MESS ( 15,  RC (2,  1 > , RC (2, 2) , RC (2, 3) , £) 
GOTO  2 
END  IF 


5 


20 


PQI  I  PI  FQBf7 

OPEN  (SUNIT, FILE=SHFILE,  STATUS=’ OLD’ ) 

TLINE ( 1 s80) =* *X*’ 

TLINE (2:2) =CMD ( 1 ) 

READ (SUNIT, ’ (A80)’)  LINE 
IF  (TLINE(1 :3)  . EQ.  LINE(1:3))  THEN 
READ (LINE (4:5),’ (12)’)  IG 
J=0 

DO  20  1=1, IG, 1 

READ  (SUNIT,  MA80)  ’  )  LINE 
J=J+1 

CALL  MENUDR  (LINE,  J,  1,2,0,  1,  1) 

IF  (MOD (I, 22)  .EQ.  0)  THEN 
IF  (I  .EQ.  IG)  THEN 

CALL  MESS (19, RC (3, 1 ) , RC (3, 2) , RC (3, 3) , 7) 
READ ( ITR, ’ ( A1 ) ’ )  CMD(l) 

CLOSE  (SUNIT) 

GOTO  1 

ELSE 

CALL  MESS ( 16, RC (3, 1 ) , RC (3, 2) , RC (3, 3) , 6) 
READ (ITR, ’ (Al)* >  CMD(l) 

CALL  CLEAR (7,0) 

J=0 

END  IF 

END  IF 

CONTINUE 

CALL  MESS (19,  RC (3,  1 ) , RC (3, 2) , RC (3, 3) , 6) 

READ  (ITR,  MAD’ )  CMD(1> 

CLOSE  (SUNIT) 

SOTO  1 

END  IF 


GOTO  5 
END 

SUBROUTINE  SADD (ITR,  SUN IT 1,  SUNIT2, SUNIT3, SUNIT4, 

*  SFILE1,  SFILE2,  SFILE3,  SFILE4,  SMUNIT, 

*  SMFILE) 

C  THIS  SUBROUTINE  ADDS  ELEMENTS  TO  THE  SUBSTANCE-SOURCE  DATA  BASE 


CHARACTER*40 

CHARACTER*8 

CHARACTERS 

CHARACTER*! 


T1 (2),CINIT1,CINIT2, TEMP0 
T2 ( 1 1 > 

SF I LE 1 , SF I LE2 , SF I LE3, SF I LE4, SMF I LE 
INP(l) 


INTEGER  ISET,  ITR,  I,  J,  SUNIT1, SUNIT2,  SUNIT3, 1ST, JST, 

*  SUNIT4,  RC(13,  3),  ST (3),  ITT, HD1, HD2, HD4 


INTEGER 


SINIT1(10), HD3 (10) 


nonnnoo  nn 


REAL 


2000 

5 

C 

C 

415 


460 


S2 (10) ,53(4),  S4 (11) 

LOGICAL  FLAG, FLAG1 , FLAG2, FLAG3, FLAG4 

DATA  ST  /0, 0, 0/ 

ITT=-1 

DO  5  1=1, 11, 1 

T2  < I ) (1:8)='  ’ 

CONTINUE 
Till) (1:40)=’  ’ 

Tl(2) (1:40)=’  ’ 

DISPLAY  THE  MAIN  MENU 

CALL  MENUSV ( SMF I LE , 180, RC, 13, SMUNIT) 

READ  IN  THE  SUBSTANCE  AND  THE  SOURCE  FROM  THE  MENU 
IST=1 

CALL  MENURD(RC, 13,  1ST,  2,  Tl,  ITR) 

CHECK  TO  SEE  IF  THE  SUBSTANCE  OR  SOURCE  IS  BLANK 
CAN  NOT  GO  ON  IF  EITHER  SUBSTANCE  OR  SOURCE  IS  BLANK 
IF  ( (Tl < 1 )  .EQ.  ’  ’ ) . OR. (Tl (2)  . EQ.  ’  ’>)  THEN 
IF  (Tl (2)  .EQ.  ’  ’)  IST=2 
IF  (Tl (1)  .EQ.  ’  ’)  IST=1 
GOTO  415 

END  IF 

IF  ( (Tl  ( 1 )  .EQ.  ’  ?’ ).0R.  (Tl  (2)  .  EQ.  ’  ?’ )  >  THEN 
IF  (Tl  (2)  .EQ.  ’?’)  IST=2 
IF  (Tl  ( 1 )  .EQ.  ’?’)  IST=1 
GOTO  415 

END  IF 


CHECK  TO  SEE  IF  THE  SUBSTANCE  IS  IN  THE  DATA  BASE  IF  SO  DISPLAY 
THE  BMW,  10,  30  AND  60  MIN  PEL  AND  DO  NOT  ALLOW  THEM  TO  BE  MODIFIED 

ISET=2  ==)  THAT  THE  USER  ENTERED  SUBSTANCE  DATA  AND  SHOULD  BE  ALLOWED 
TO  CHANGE  IT. 

I SET =3  ==)  THE  SUBSTANCE  DATA  CAME  FROM  THE  DATA  BASE  AND  THE  USER 
SHOULD  NOT  BE  ALLOWED  TO  CHANGE  IT. 

ISET=2 

INQUIRE  (FILE=SFILE1, EXIST=FLAG) 

IF  (FLAG)  THEN 

OPEN  (SUNIT1, FILE=SFILE1,  STATUS*’ OLD’ ,  ACCESS*’ DIRECT’ , 

*  FORM*’ UNFORMATTED’ , RECL-120) 

READ (SUNIT1, REC=1 )  HD1 
DO  450  1*2,  HD1,  1 

READ (SUNIT1, REC=I)  CINIT1, SINIT1, S2 
IF  (CINIT1  .EQ.  Tl ( 1 ) >  THEN 
DO  460  J=l, 5, 1 

WRITE (T2(J+2) (1:8),’ (F8. 4)’ )  S2(J) 

CONTINUE 
ST (3) *0 

CALL  MENUWR(RC,  13,  3,  7, T2, 0, 1, ST) 

CLOSE  (SUN IT 1) 

ISET*3 
JST-8 
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GOTO  320 


END  IF 


450  CONTINUE 

CLOSE  (SUNIT1) 
END  IF 


C  DISPLAY  THE  REST  OF  THE  MENU  INCLUDING  GMW,  10,  30,  60  MIN 
C  PELS  IF  NECESSARY. 

IST=3 

420  CALL  MENURD(RC, 13, 1ST, 7, T2, ITR) 

JST=a 

320  CALL  MENURD  < RC, 13, JST,  1 1 , T2, ITR) 


C  SCANNING  THE  COMMAND  INPUT  ROW 

200  INP ( 1 ) =’  ’ 

CALL  MENURD (RC, 13, 12, 12, INP, ITT) 

IF  ( INP ( 1 )  .EQ.  ’  M  THEN 

ST (3) =1 

CALL  MENUWR  ( RC,  13,  12,  12,  INP,  0,  1,ST) 

CALL  MESS (4, RC(13, 1 ) , RC ( 13, 2) , RC ( 13, 3) ,  2) 
"■)  IF  ( ISET  .EQ.  3)  THEN 

JST=8 
GOTO  320 
END  IF 

IF  (ISET  .EQ.  2)  THEN 

IST=3 
GOTO  420 
END  IF 

DO  210  J=l, 7, 1 
T2(J) (1:8)=’  ’ 

210  CONTINUE 

IST=1 
GOTO  415 
END  IF 

IF  ( INP ( 1 )  .EQ.  ’X*)  RETURN 
IF  ( INP ( 1 )  .EQ.  'R')  GOTO  2000 
IF  ( INP ( 1 )  .NE.  'A')  GOTO  200 


C  CHECK  THE  REQUEST  FOR  ERRORS 

CALL  MENUCK (T2, S4, 11, »  (F4.4)’,  IERR) 

IF  (IERR  .NE.  0)  THEN 

INP ( 1 )  =’  * 

ST<3>*1 

CALL  MENUWR  (RC,  13,  12,  12,  INP,0,  1,ST> 

CALL  MESS  (1,  RC  ( 13,  1 ) ,  RC  ( 13,  2) ,  RC  •  *  3) ,  6) 

IST-IERR 

IF  (IERR  .LE.  7)  GOTO  420 
GOTO  320 
END  IF 


C  THE  GMW,  10,  30,  60  MIN  PELS  AND  THE  SOURCE  STRENGTH  ARE  NOT 
C  ALLOWED  TO  BE  ZERO. 

DO  180  1*3,6,  1 

IF  (S4(I>  .LE.  0.0)  THEN 
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CONTINUE 
IF  <S4<8> 


I  ST- 1 

INP ( 1 )  =*  ’ 

ST (3) =1 

CALL  MENUWR  <  RC, 13, IS, 12, INP, 0, 1,ST) 

CALL  MESS ( 1,  RC ( 13, 1 ) ,  RC ( 13, 2) , RC ( 13, 3) , 6) 
SOTO  420 
END  IF 

0)  THEN 
JST-B 
INP ( 1 )  =’  ’ 

ST  <3) *1 

CALL  MENUWR  (RC,  13,  12,  12,  INP,0,  1,ST) 

CALL  MESS ( 1 , RC (13, 1), RC(13, 2), RC ( 13,  3),  6) 
GOTO  320 
END  IF 


AND  S3 ( 1-4)  ARRAYS 


LOAD  THE  S2 ( 1-10) 
S3 ( 1 ) =S4 (8) 
S3(2)-S4(9) 

S3 (3) -S4 (10) 

S3 (4) =S4 (11) 

DO  181  1*1, 10, 1 
S2 ( I ) =0. 0 
CONTINUE 
DO  182  1-1,5,  1 
S2 ( I ) -S4 (1+2) 
CONTINUE 


IF  NO  DATA  BASE  EXISTS  THEN  INITIALIZE  IT 
INQUIRE  (FILE=SFILE1,  EXIST -FLAB) 

IF  (.NOT.  FLAG)  THEN 

OPEN  (SUNIT1, FILE-SFILE1, STATUS-’  NEW’ , 
k  ACCESS-’ DIRECT’ , FORM-’ UNFORMATTED* , RECL-120) 

OPEN  (SUNIT2, FILE-SFILE2, STATUS-’ NEW’ , 
y  ACCESS-’ DIRECT’ , FORM-’ UNFORMATTED’ , RECL-40) 

OPEN  ( SUN I T3, F I LE-SF I LE3,  STATUS-’  NEW* , 
k  ACCESS-*  DIRECT’ , FORM-’  UNFORMATTED’ , RECL-40) 

OPEN  (SUNIT4, FILE-SFILE4,  STATUS-'  NEW* , 

►  ACCESS-’  DIRECT' ,  FORM-’ UNFORMATTED’ , RECL-16) 

INITIALIZE  THE  HEADERS 
HD1-1 

WRITE (SUNIT1, REC-1 )  HD1 
WRITE (SUNIT2, REC-1 >  HD1 
WRITE (SUNIT3, REC-1)  HD1 
WRITE (SUNIT4, REC-1)  HD1 
WRITE (SUNIT1, REC-2)  HD1 
WRITE (SUNIT2, REC-2)  HD1 
WRITE (SUN I T3, REC-2)  HD1 
WRITE (SUN I T4, REC-2)  HD1 
CLOSE (UN IT-SUNITl) 

CLOSE (UNIT-SUNIT2) 

CLOSE (UNIT-SUNIT3) 

CLOSE (UNIT-SUNIT4) 

ENDIF 

OPEN  (SUNIT1,  FI LE-SF  I LEI,  STATUS-’  OLD* ,  RECL-120, ACCESS-’ DIRECT* , 


*  F  ORM=>  UNFORMATTED' ) 

OPEN  (SUNIT2,  FILE=SFILE2,  STATUS*' OLD’ , RECL=40, ACCESS*’ DIRECT’ , 

*  FORM*' UNFORMATTED' ) 

OPEN  (SUNIT3, FILE=SFILE3,  STATUS*’ OLD’ ,  RECL=40, ACCESS*’ DIRECT’ , 

*  FORM*' UNFORMATTED’ > 

OPEN  (SUNIT4, FILE*SFILE4, STATUS*’ OLD’ , RECL=16, ACCESS*’ DIRECT’ , 

*  FORM*’ UNFORMATTED’  ) 


C  CHECK  FOR  SUBSTANCE  IN  THE  SUBSTANCE  DATA  BASE 
x  READtSUNITl, REC=1)  HD1 

DO  35  1*2, HD1, 1 

READ (SUN I Tl, REC=I)  CINIT1, SINIT1 
>  IF  (CINIT1  .EQ.  Tl ( 1 ) >  THEN 

READ (SUNIT2, REC=1 )  HD2 
DO  42  J=2, HD2, 1 

■)  READ(SUNIT2,  REC=J)  CINIT2 

IF  (CINIT2  .EQ.  Tl  (2) >  THEN 


C 

25 


2S 


* 


SEE  IF  THE  ENTRY  ALREADY  EXISTS 
DO  26  K=1 , 9, 1 

IF  (SINITl(K)  .EQ.  J)  THEN 
CALL  MESS (2, RCC13, 1), RC(13, 2), RCC13, 3), 6) 
GOTO  1000 

END  IF 

CONTINUE 

IF  (SINIT1 (10)  .NE.  0)  THEN 

READ (SUNIT1, REC=SINIT1 ( 10) )  CINIT1, 

SINIT1 

GOTO  25 

END  IF 


28 


I 


-  o 


f 


./ 


READ (SUNIT1, REC=I )  CINIT1, SINIT1 
READ (SUNIT4, REC=1 )  HD4 
HD4=HD4+1 

WRITE (SUNIT4, REC*1 )  HD4 
I I I*HD4+1 

WRITE (SUNIT4, REC=HD4)  S3 
WRITE (SUNIT4, REC*I II)  S3 
DO  27  KK*1, 9,  1 

IF  (SINITKKK)  .EQ.  0)  THEN 
SINIT1 (KK)=J 
111=1+1 

WRITE (SUNIT1, REC* I )  CINIT1, SINIT1, S2 
WRITE (SUNIT1, REC=I I I )  CINIT1 
READ ( SUN I T3, REC* I)  HD3 
HD3 (KK) *HD4 

WRITE (SUNIT3, REC=I )  HD3 
WRITE (SUNIT3,  REC*III)  HD3 
CALL  MESS (3, RC ( 13, 1 ) , RC ( 13, 2) , RC ( 13, 3) , 6) 

GOTO  1000 

END  IF 

CONTINUE 

IF  (SINIT1 ( 10)  .EQ.  0)  THEN 
HD1-HD1+1 
SINIT1 <10)*HD1 

WRITE (SUNIT1, REC*I )  CINIT1, SINIT1, S2 
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29 


42 


WRITE (SUNIT1, REC=1>  HD1 
DO  29  K=2, 10, 1 
SINIT1 (K) =0 
HD3 (K) =0 
CONTINUE 
SINIT1 (1)“J 
HD3 ( 1 >  =HD4 
I I I=HD1+1 


WRITE (SUNIT1, REC=HD1 ) 
WRITE <SUNIT3,  REC«=HD1> 
WRITE (SUNIT1, REC-III) 
WRITE (SUNIT3, REC=III> 
CALL  NESS (3, RC ( 1 3, 1), RC ( 1 3, 
GOTO  1000 


CINIT1,SINIT1,S2 

HD3 

CINIT1 

HD3 

2),  RC(13,3),6> 


END  IF 

I=SINIT1 (10) 

READ(SUNIT1, REC=I)  CINIT1, SINIT1 
GOTO  28 


CONTINUE 


END  IF 


C 


46 


45 


47 


ADD  NEW  SOURCE  TO  THE  SOURCE  DATA  BASE 
HD2=HD2+1 

WRITE (SUNIT2, REC=1)  HD2 
I I I=HD2+1 

WRITE (SUNIT2, REC=HD2)  T1 (2) 

WRITE (SUNIT2, REC=I I I )  T1 (2) 

READ(SUNIT4, REC=1)  HD4 
HD4«=HD4+1 

WRITE (SUNIT4, REC=1 )  HD4 
I I I=HD4+1 

WRITE (SUNIT4, REC=HD4)  S3 
WRITE (SUNIT4, REC=III)  S3 
DO  45  JJ*1,9,  1 

IF  (SINITl(JJ)  .EQ.  0)  THEN 
SINIT1 ( JJ) =HD2 

WRITE (SUNIT1, REC=I>  CINIT1, SINIT1, S2 
READ (SUN I T3, REC=I)  HD3 
HD3(JJ)*=HD4 

WR I TE ( SUN I T3, REC= I )  HD3 
CALL  NESS (3, RC ( 13, 1 ) , RC ( 13, 2) , RC ( 13, 3) , 6) 
GOTO  1000 

END  IF 

CONTINUE 

IF  (SINIT1 ( 10)  .EQ.  0)  THEN 
HD1*HD1+1 
SINIT1 ( 10) =HD1 

WRITE (SUNIT1, REC=I )  CINIT1 , SINIT1, S2 
WRITE (SUNIT1, REC=1>  HD1 
DO  47  K=2, 10, 1 
SINIT1 (K) =0 
HD3(K)=0 
CONTINUE 
SINIT1 (1)-HD2 
HD3 ( 1 ) =HD4 
I I I=HDi+l 

WRITE (SUNIT1, REC-HD1)  CINIT1, SINIT1,  S2 
WRITE (SUNIT3, REC-HD1)  HD3 
WRITE (SUNIT1, REC-III)  CINIT1 
WRITE (SUNIT3, REC*III)  S3 
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35  CONTINUE 


COLL  MESS (3, RC ( 13, 1 ) ,  RC ( 13, 2) , RC ( 13, 3) , 6) 
GOTO  1000 

END  IF 

I=SINIT1 (10) 

READ ( SUNI T 1 , REC= I >  CINIT1, SINIT1 
GOTO  46 

END  IF 


) 


C 

C 


O 


55 


^  50 


A  NEW  ADDITION  IS  TO  BE  MADE  TO  SUB. DB 

THE  SOURCE  IS  IN  SOUR. DB  BUT  THE  SUBSTANCE  IS  NEW  IN  SUB. DB 
READ ( SUN I T2, REC= 1 )  HD2 
DO  50  J=2, HD2, 1 

READ ( SUN I T2, REC= J )  C I N I T2 
IF  (CINIT2  .EQ.  T1 (2) )  THEN 

DO  55  1=2, 10, 1 
SINIT1 < I ) =0 
HD3 ( I ) =0 
CONTINUE 
HD1=HD1+1 


CONTINUE 


SINIT1 <1)=J 

READ (SUNIT4, REC=1 )  HD4 
WRITE (SUNIT1 , REC=1 )  HD1 
I I I=HD1+1 

WRITE (SUNIT1, REC=HD1 )  T1 ( 1 ) , SINIT1, S2 
WRITE (SUNI Tl, REC=I 1 1 )  Tl(l> 

HD4=HD4+1 

JJJ=HD4+1 

WR I TE ( SUN I T4 , REC=HD4  >  S3 
WRITE (SUNIT4, REC=JJJ)  S3 
WRITE (SUNIT4, REC=1)  HD4 
HD3 ( 1 ) =HD4 

WRITE (SUNIT3, REC=HD1 )  HD3 

WRITE (SUNIT3, REC=I I I )  HD3 

CALL  MESS (3, RC ( 13, 1 > , RC ( 13, 2) , RC ( 13, 3) , 6) 

GOTO  1000 

END  IF 


o 


c 

c 


60 


A  NEW  ADDITION  IS  TO  BE  MADE  TO  BOTH  SUB. DB  AND  SOUR. DB 
THE  SUBSTANCE  AND  THE  SOURCE  ARE  NOT  IN  THE  DATABASE. 
READ (S.  iNIT4,  REC=1  >  HD4 
DO  60  1*2, 10,  1 
SINIT1 ( I ) =0 
HD3 ( I ) =0 
CONTINUE 
HD1=HD1+1 
HD2*HD2+1 
SINIT1 ( 1 ) =HD2 
WRITE (SUNIT1, REC=1)  HD1 
WRITE (SUNIT2, REC-1)  HD2 
WRITE (SUNIT1, REC*HD1>  Tl ( 1 ) , SINIT1, S2 
WRITE (SUNIT2, REC=HD2)  Tl (2) 
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Ill-  HD1+1 
JJJ-  HD2+1 

WRITE (SUNIT1, REC-I I I )  Tl(l) 

WRITE (SUNIT2, REC-JJJ)  T1 (2) 

HD4-HD4+1 

WRITE (SUNIT4, REC-HD4)  S3 
WRITE (SUNIT4, REC-1)  HD4 
KKK-  HD4+1 

'  WRITE (SUN I T4, REC-KKK)  S3 

HD3 ( 1 ) -HD4 

WRITE (SUNIT3, REC-HDl )  HD3 
WRITE (SUNIT3, REC-III)  HD3 
CALL  MESS (3, RC(13, 1) ,  RC ( 13,  2) ,  RC ( 13, 3) , 6) 

1000  CLOSE  (SUNIT1) 

)  CLOSE  (SUNIT2) 

CLOSE  (SUNIT3) 

CLOSE  (SUNIT4) 

>  I SET-1 

GOTO  200 

END 

SUBROUTINE  SSEAR (EFLAG, ITR,  SUNIT1, SUNIT2, SUNIT3, SUNIT4, OPT, SKEY, 

*  SDATA, SFILE1 , SFILE2, SFILE3, SFILE4, SMUNIT, SMFILE) 

'  C  THIS  SUBROUTINE  SEARCHES  FOR  ELEMENTS  FROM  THE  SOURCE-SUBSTANCE  DATA  BASE 

CHARACTER* 1  INP ( 1 ) ,  OPT,  OPT1 

CHARACTER*40  CINIT1 ,  CINIT2,  SKEY ( 1 > , TC ( 1 ) 

CHARACTER*8  TEMP ( 8 ) 

CHARACTER*?  SFILE1,  SFILE2,  SFILE3, SFILE4, SMFILE 

i 

INTEGER  ITR,  I,  SUNIT1,  SUNIT2,  SUNIT3,  SUNIT4, SMUNIT, 

*  RC (4, 3) , ST (3) ,  RCC (7,  3) ,  EFLAG,  HD 

INTEGER  SINIT1 (10),HD3(10> 

REAL  SDATA (1),  82(10), S3 (4) 

LOGICAL  FLAG1,  FLAG2,  FLAG3, FLAG4 

DATA  ST  /0, 0,  1/ 

*“!  ITT— 1 

OPT1-*  » 

O  IP  .EQ.  ’»’)  GOTO  20 

100  SKEY ( 1 ) ( 1 s40) ’ 

SKEY (2) ( 1 j40) -*  * 

105  CALL  MENUSV (SMFILE,  181,  RC,  4,  SMUNIT) 

C  IF  ALREADY  BEEN  IN  THE  MENU  ALLOW  THE  USER  TO  QUIT 
IF  (OPT1  .EQ.  »*’)  THEN 

ST (3) *0 

CALL  MENUWR (RC, 4, 1,2, SKEY, 0, 1,ST) 

GOTO  15 
END  IF 

IST-1 

5  CALL  MENURD(RC,  4,  1ST,  2,  SKEY, ITR) 
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C  CHECK  THE  REQUEST  FOR  ERRORS 

IF  (  (SKEY  ( 1  >  .EG).  ’  ’)  .OR.  (SKEY (2)  .  EQ.  ’  *>)  THEN 
IF  (SKEY (2)  .EQ.  ’  ’)  IST=2 
IF  (SKEY ( 1 )  .EQ.  »  ’)  IST=1 
GOTO  5 

END  IF 


C 

15 


) 


) 


SCANNING  THE  COMMAND  INPUT  ROW 
INP(1)=*  ’ 

CALL  MENURD(RC, 4, 3, 3, INP, ITT) 

IF  ( INP ( 1 )  .EQ.  ’  ’)  THEN 

ST (3) *1 

CALL  MENUWR(RC,  4,3,  3,  INP,  0,  1,ST) 

CALL  MESS  (4,  RC  (4,  1 ) ,  RC  (4,  2) ,  RC  (4,  3) ,  1) 

IST=1 

GOTO  5 

END  IF 

IF  ( INP ( 1 )  .EQ.  ’X’)  RETURN 
IF  (INP ( 1 )  .NE.  ’S’)  GOTO  15 


O  C 


) 


o 


ALLOW  THE  QUESTION  MARK  TO  BE  ANSWERED 
IF  ( (SKEY ( 1 )  .EQ.  ’  ?’  ).OR.  (SKEY (2)  .  EQ.  '  ?’ ) )  THEN 
INQUIRE  (FILE=SFILE1,  EXIST=FLAG1 ) 

INQUIRE  (FILE=SFILE2, EXIST=FLAG2) 

IF  ( (.NOT.  FLAGD.OR.  (.NOT.  FLAG2) )  THEN 
CALL  MESS(ia,  RC (4,  1 ) ,  RC (4,  2) , RC (4, 3) , 7) 

GOTO  15 

END  IF 

IF  (SKEY ( 1 )  .EQ.  ’?’)  THEN 

CALL  SBQST (SKEY,  SUNIT1,  SUNIT2,  SFILE1,  SFILE2,  SMUNIT,  SMFILE, 

*  ITR, EFLAG) 

IF  (EFLAG  .NE.  0)  THEN 

ST(3)*1 

CALL  MENUWR(RC, 4, 3, 3, INP, 0, 1,  ST) 

CALL  MESS (5, RC(4, 1 ) , RC (4, 2) , RC (4, 3) , 1) 

IST=2 

GOTO  5 

ENDIF 

END  IF 

IF  (SKEY (2)  .EQ.  ’?’)  THEN 

CALL  SRCQST (SKEY, SUNIT1, SUNIT2, SFILE1, SFILE2, SMUNIT, SMFILE, 

*  ITR, EFLAG) 

IF  (EFLAG  .NE.  0)  THEN 

ST (3) =1 

CALL  MENUWR(RC,  4, 3, 3,  INP, 0, 1,ST) 

CALL  MESS (5, RC(4, 1 ) , RC (4, 2) , RC (4, 3) ,  1) 

IST»»1 

GOTO  5 

ENDIF 

ENDIF 

OPTl*’ *’ 

GOTO  105 

ENDIF 


C  CHECK  THAT  THE  DATABASES  EXISTS 

20  INQUIRE  <FILE-SFILE1,EXIST«FLAG1> 

INQUIRE  (FILE«SFILE2,EXIST«FLAG2> 

I NQU IRE  ( F I LE-SF I LE4,  EX  I ST-FLAG4 ) 
INQUIRE  (FILE-SFILE3.EXIST-FLAG3) 

IF  ((.NOT.  FLAGD.OR.  (.NOT.  FLAG2) .  OR. 
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non 


*  (.NOT.  FLAG3) .  OR.  (.  NOT.  FLAG4) )  THEN 

IF  (OPT  .EQ.  ’&’)  THEN 

EFLAG=10 
RETURN 
END  IF 

CALL  MESS (5,  RC (4,  1 ) ,  RC  (4,  2) ,  RC  (4,  3) ,  7) 

GOTO  15 
END  IF 

C  OPEN  THE  DATABASES 

OPEN  (SUNIT1, FILE=SFILE1, STATUS®’ OLD* , RECL=120, ACCESS®*  DIRECT* , 

*  FORM**  UNFORMATTED*  > 

OPEN  (SUNIT2, FILE=SFILE2,  STATUS**  OLD’ , RECL=40, ACCESS*’ DIRECT’ , 

*  FORM*’ UNFORMATTED* ) 

OPEN  (SUNIT3,  FILE=SFILE3,  STATUS*’  OLD* , RECL=40, ACCESS*’ DIRECT’ , 

*  FORM*’ UNFORMATTED’ ) 

OPEN  (SUNIT4, FILE=SFILE4, STATUS*’  OLD’ , RECL=16, ACCESS*’ DIRECT’ , 

*  FORM*' UNFORMATTED’  ) 

FLAG 1*. FALSE. 

FLAG2*. FALSE. 

FLAG4*. FALSE. 

READ ( SUN I T 1 , REC* 1 )  HD 
DO  25  1*2, HD,  1 

READ(SUNIT1, REC=I>  CINIT1,  SINIT1, S2 

IF  ( (SKEY  ( 1 )  .EQ.  CINITD.OR.  (SKEY(l)  .  EQ.  *  *’ ) )  THEN 
READ (SUN I T3, REC* I)  HD3 
FLAG3*.  FALSE. 

ICNT=12 

DO  30  11*1, 9, 1 

IF  (SINIT1 (II)  .EQ.  0)  GOTO  30 
FLAG1*. TRUE. 

DO  80  I J*l, 5, 1 

SDATA  <  I  J) =S2 ( I J) 

60  CONTINUE 

READ (SUNIT2,  REC*SINIT1 (II))  CINIT2 
IF  ( (CINIT2  .EQ.  SKEY (2)). OR. 

*  (SKEY (2)  .EQ.  ’*’)>  THEN 

READ ( SUN I T4, REC-HD3 (II))  S3 
DO  81  I J*l, 4, 1 

SDATA ( 10+1 J) *S3 ( I J) 

81  CONTINUE 

IF  (OPT  .  EQ.  *  *’ )  THEN 

CLOSE  ( SUN I T 1 ) 

CLOSE  (SUNIT2) 

CLOSE  (SUNIT3) 

CLOSE  (SUNIT4) 

RETURN 
ENDIF 

FLAG2-. TRUE. 

FLAG3  IS  A  SNITCH  USED  TO  DECIDE  WHETHER  TO  WRITE  HEADER 
FLAG3  »  .FALSE.  =*>  WRITE  HEADER 
FLAG3  =  .TRUE.  **)  DO  NOT  WRITE  THE  HEADER 

IF  (.NOT.  FLAG3)  THEN 
FLAG3-. TRUE. 

CALL  MENUSV (SMFILE, 184, RCC, 7, SMUNIT) 
ST(3)-0 
TC< 1 ) "CINITl 


140 


CALL  MENUWR  ( RCC,  7,  1 ,  1 ,  TC,  0,  1 ,  ST > 

DO  40  K=l,5,  1 

WRITE (TEMP (K+l) (1:B),’  (F8. 3) * )  S2(K> 

40  CONTINUE 

ST (3) =0 

CALL  MENUWR (RCC, 7, 2, 6, TEMP, 0, 1, ST) 

END  IF 

DO  65  K=1 , 4, 1 

WRITE (TEMP <K> (1:8), ’ (F8. 1)’ )  S3(K) 

65  CONTINUE 

CALL  MENUDR (CINIT2, ICNT, 1,2, 0, 1,  1) 

CALL  MENUDR (TEMP(l) (1:8),  ICNT,  41,2,0,  1,1) 
CALL  MENUDR (TEMP (2) (1:8), ICNT,  51,2,0,  1,  1) 
CALL  MENUDR (TEMP (3) (1:8), ICNT, 61, 2,0, 1,1) 
CALL  MENUDR (TEMP (4) (1:8), ICNT, 71,2, 0, 1, 1) 
ICNT=ICNT+1 


30 


CONTINUE 


END  IF 


C  FLAG2  IS  IS  TO  TELL  IF  ANYTHING  WAS  WRITTEN  TO  THE  SCREEN 

C  FLAG2  *  .TRUE.  ==>  SOMETTHING  IS  ON  TTHE  SCREEN 

C  FLAG2  =  -FALSE.  ==>  NOTHING  WAS  WRITTEN  ON  THE  SCREEN 

IF  (FLAG2)  THEN 
50  INP ( 1 )  =’  * 

CALL  MENURD(RCC,  7,  7,  7, INP, ITT) 

IF  ( INP  ( 1 )  .EQ.  ’XM  THEN 

CLOSE  (SUNIT1 ) 

CLOSE  (SUNIT2) 

CLOSE  (SUNIT3) 

CLOSE  (SUNIT4) 

DPT1=’*» 

GOTO  100 
END  IF 

IF  ( INP ( 1 )  .EQ.  ’CM  THEN 

FLAG 1=. FALSE. 

FLAG2*. FALSE. 

FLAG4*. TRUE. 

GOTO  25 
END  IF 

GOTO  50 
END  IF 


25  CONTINUE 


END  IF 


IF  ( ( (FLAG1 ) .  AND.  (FLAG2) ) . OR.  (FLAG4) )  THEN 

CLOSE  (SUNITl ) 
CLOSE  (SUNIT2) 
CLOSE  (SUNIT3) 
CLOSE  (SUNIT4) 
OPTl-’#’ 

GOTO  100 
END  IF 

IF  (.NOT.  FLAG1 )  THEN 

IF  (OPT  .  EQ.  ’  &’  )  THEN 

EFLAG*1 1 
CLOSE  (SUNITl) 
CLOSE  (SUNIT2) 
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■') 

1 


CLOSE  (SUNIT3) 
CLOSE  (SUNIT4) 
RETURN 
ENDIF 

IST-1 
SOTO  35 
ENDIF 

IF  (.NOT.  FLAGS)  THEN 

IF  (OPT  .EQ.  *»’>  THEN 

EFLAG-13 
CLOSE  (SUNIT1 ) 
CLOSE  (SUN ITS) 
CLOSE  (SUNIT3) 
CLOSE  (SUNIT4) 
RETURN 
ENDIF 

I  ST-3 
ENDIF 

35  INP(l)-'  * 

ST (3) *1 

CALL  MENUWR  ( RC,  4,  3,  3,  INP,  0,  1 ,  ST) 

CALL  MESS (5,  RC (4,  1 ) ,  RC (4,  S) , RC (4, 3) , 7) 

CLOSE  (SUNIT1) 

CLOSE  (SUNITS) 

CLOSE  (SUNIT3) 

CLOSE  (SUNIT4) 

GOTO  5 


END 

SUBROUTINE  SDELdTR,  SUNITl,  SUNITS,  SUNIT3,  SUNIT4,  SFILE1,  SFILES, 

*  SFILE3, SFILE4, SMUNIT, SMFILE) 

C  THIS  SUBROUTINE  DELETES  ELEMENTS  FROM  THE  SOURCE-SUBSTANCE  OKA  BASE 


CHARACTER* 1 
CHARACTER*40 
CHARACTERS 
CHARACTER*? 


INP ( 1 ) , OPT 

CINIT1,  CINIT3, DKEY (S) , TC ( 1 ) 

TEMP (10) 

SFILE1,  SFILES, SFILE3, SFILE4, SMFILE 


) 


INTEGER  ITR, RC (4,  3) ,  I, SUNITl , SUNITS, SUNIT3, SUNIT4, ST (3) , 

*  RCC(7, 3) ,  SMUNIT, EFLAG 


INTEGER  SINIT1(10),  HD3 ( 10) ,  HD, SAV ( 10) , SAV1 (10) 


o 


REAL  SS  ( 10) ,  S3  (4) 

LOGICAL  FLAG1 ,  FLAGS,  FLAG3, FLAG4 


DATA  ST/0,0,0/ 

ITT— 1 
OPT-’  ’ 

100  DKEY(l) (1:40)-’  ’ 

DKEY (S) (1*40) »*  » 

105  CALL  MENUSV (SMFILE,  1B5,  RC,  4,  SMUNIT) 


IF  (OPT  . EQ.  ’  4’  >  THEN 

ST (3) -0 

CALL  MENUWR (RC, 4, 1, S, DKEY, 0, 1,ST> 

SOTO  15 

ENDIF 
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IST=1 

CALL  MENURD (RC,  4,  1ST,  £,  DKEY,  ITR) 

CHECK  THE  REQUEST  FOR  ERRORS 
IF  ( (DKEY ( 1 )  .EQ.  ’  ’>  .OR.  (DKEY (2) 
IF  (DKEY (2)  .EQ.  »  ’>  IST=2 
IF  ( DKEY ( 1 )  .EQ.  *  •)  IST=1 
GOTO  5 


SCANNING  THE  COMMAND  INPUT  ROW 
INP ( 1 )  -’  * 

CALL  MENURD  (RC,  4,  3,3,  INP,  ITT) 


THEN 


ENDIF 


( INP ( 1 ) 


( INP ( 1 ) 
( INP ( 1 ) 


THEN 
ST (3) =1 

CALL  MENUWR (RC, 4, 3, 3, INP, 0, 1, ST) 

CALL  MESS  (4,  RC  (4,  1 ) ,  RC  (4,  2) ,  RC  (4,  3) ,  1) 

IST=1 

GOTO  5 

ENDIF 

RETURN 

GOTO  15 


ALLOW  THE  QUESTION  MARK  TO  BE  ANSWERED 
IF  ( (DKEY ( 1)  .EQ.  ’ ?’ ) . OR. (DKEY (2)  . EQ.  »  ?*  ) )  THEN 
I NQU IRE  (FI LE=SF I LE 1 , E X I ST=FLAG 1 ) 

I  NQU  IRE  (FILE-SFILE2,  EX  I  ST=FL  AG2 ) 

IF  ((.NOT.  FLAGD.OR.  (.NOT.  FLAG2))  THEN 
CALL  MESS (18,  RC (4,  1 ) ,  RC (4,  2) , RC (4, 3) , 7) 

GOTO  15 

ENDIF 

IF  (DKEY ( 1 )  .EQ.  ’  ?•  )  THEN 

CALL  SBQST (DKEY, SUN IT 1,  SUNIT2,  SFILE1,  SFILE2, SMUNIT, SMFILE, 

»  ITR, EFLAG) 

IF  (EFLAG  .NE.  0)  THEN 

ST (3) =1 

CALL  MENUWR  (RC,  4,  3,  3,  INP,  0,  1,ST) 

CALL  MESS (5,  RC (4, 1 ) , RC (4, 2) , RC (4, 3) , 1) 

I  ST =2 
GOTO  5 
ENDIF 

ENDIF 

IF  (DKEY (2)  .EQ.  '  ?’ >  THEN 

CALL  SRCQST (DKEY, SUNIT1,  SUNIT2,  SFILE1,  SFILE2, SMUNIT, SMFILE, 
»■  ITR, EFLAG) 

IF  (EFLAG  .NE.  0)  THEN 

ST (3) =1 

CALL  MENUWR  (RC,  4,3,3,  INP,  0,  1,  ST) 

CALL  MESS (5, RC(4, 1 > , RC (4, 2) , RC (4, 3) , 1 ) 

IST-1 

GOTO  5 

ENDIF 

ENDIF 

OPT-’ &’ 

GOTO  105 

ENDIF 

CHECK  THAT  THE  DATA  BASES  EXIST 
INQUIRE  (FILE-BFILE1,  EXIST-FLAG1) 
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I NQU IRE  (FI LE=SF I LE2,  EX I ST=FLAG2 ) 

I NQU IRE  (FI LE=SF I LE4 , E  X I ST=FL AG4 ) 

I NQU IRE  (FI LE=SF I LE3, EX  I ST=FLAG3 ) 

IF  ((.NOT.  FLAGD.OR.  (.NOT.  FLAG2) .  OR. 

*  (.NOT.  FLAG3).0R.  (.NOT.  FLAG4) >  THEN 

CALL  MESS (5,  RC (4,  1 ) ,  RC (4, 2) , RC94, 3:, 7) 
GOTO  15 
END  IF 

OPEN  THE  DATABASES 

OPEN  (SUNIT1, FILE=SFILE1,  STATUS®’ OLD* ,  RECL*120, ACCESS*’  DIRECT’ , 

*  FORM*’  UNFORMATTED’  ) 

OPEN  (SUNIT2, FILE=SFILE2, STATUS*’ OLD’ , RECL*40, ACCESS*’ DIRECT’ , 

*  FORM*’ UNFORMATTED* ) 

OPEN  (SUNIT3, FILE=SFILE3,  STATUS*’  OLD’ ,  RECL=40, ACCESS*’ DIRECT’ , 

*  FORM*’ UNFORMATTED’  ) 

OPEN  (SUNIT4, FILE=SFILE4,  STATUS*’  OLD’ ,  RECL*16,  ACCESS*’  DIRECT’ , 

*  FORM*’ UNFORMATTED*  > 

FLAG1*. FALSE. 

FLAG2*. FALSE. 

FLAG4*. FALSE. 

READ (SUNIT1, REC=1 >  HD 
DO  25  1*2, HD,  1 

READ (SUNIT1, REC=I)  CIN1T1, SINIT1, S2 

IF  ( (DKEY ( 1 )  .EQ.  CINIT1 ) . OR. (DKEY ( 1 )  . EQ.  ’  *’ > )  THEN 
READ (SUN I T3, REC=I )  HD3 
FLAG1*. TRUE. 

FLAG3*. FALSE. 

ICNT=12 

ICNTT=0 

DO  30  11*1,9,1 

IF  (SINIT1 (II)  .EQ.  0)  GOTO  30 
READ (SUNIT2, REC*SINIT1 (II))  CINIT2 
IF  ( (CINIT2  .EQ.  DKEY (2)). OR. 

*  (DKEY (2>  .EQ.  ’ *’ > )  THEN 

I CNTT * I CNTT + 1 

SAV ( ICNTT) =SINIT1 (II) 

SAV1 < ICNTT) =1 I 
FLAG2*. TRUE. 

READ(SUNIT4, REC=HD3(II)>  S3 

IF  (.NOT.  FLAG3)  THEN 
FLAG3*. TRUE. 

CALL  MENUSV ( SMF I LE, 184, RCC, 7, SMUNIT) 

ST (3) =0 
TC( 1 ) *CINIT1 

CALL  MENUWR ( RCC, 7, 1 , 1 , TC, 0, 1 , ST) 

DO  40  K*1 , 5, 1 

WRITE (TEMP (K+l) (1:8),’  (F8.3)’ )  S2(K) 
CONTINUE 
ST (3) “0 

CALL  MENUWR (RCC, 7, 2, 8, TEMP, 0, 1, ST) 

END  IF 

DO  65  K-1,4,1 

WRITE (TEMP (K) (1:8),*  (F8. 1)’ )  S3(K> 
CONTINUE 

CALL  MENUDR(CINIT2, ICNT, 1,2,0, 1,  1) 


CALL  MENUDR ( TEMP ( 1 )  ( 1 ;8> , ICNT, 41, £, 0, 1,  1> 
CALL  MENUDR (TEMP (£) <1:B>, ICNT, 51, 2,0, 1, 1) 
CALL  MENUDR (TEMP (3) (1:8), ICNT, 61, 2,0, 1, 1) 
CALL  MENUDR (TEMP (4) (1:8), ICNT, 71, 2,0, 1, 1) 
ICNT=ICNT+1 


30 


CONTINUE 


END  IF 


IF  (FLAG2)  THEN 
50  INP ( 1 )  =’  * 

CALL  MENURD(RCC, 7,  7,  7,  INP,  ITT) 

IF  ( INP  ( 1 )  .EQ.  ’X’)  THEN 

CLOSE  (SUNIT1 ) 

CLOSE  (SUNIT2) 

CLOSE  (SUNIT3) 

CLOSE  (SUNIT4) 

□  PT=> 

GOTO  100 
END  IF 

IF  (INP ( 1 )  .EQ.  ’CM  THEN 

FLAG1®. FALSE. 

FLAG2=. FALSE. 

FLAG4=.  TRUE. 

DO  80  JG=1, ICNTT,  1 
SINIT1 (SAV1 (JG) )=0 
HD3 (SAV1 (JG) )=0 

80  CONTINUE 

WRITE (SUNIT1, RED=I>  CINIT1, SINIT1, S2 
WRITE (SUNIT3, REC=I>  HD3 
GOTO  25 

END  IF 

GOTO  50 

END  IF 


£5  CONTINUE 


END  IF 


IF  ( ( (FLAG1). AND. (FLAG2) ) . OR. (FLAG4) )  THEN 

CLOSE  (SUNIT1) 
CLOSE  (SUNIT2) 
CLOSE  (SUNIT3) 
CLOSE  (SUNIT4) 
OPT=’ &’ 

GOTO  100 
END  IF 

IF  (.NOT.  FLAG2)  IST=£ 

IF  (.NOT.  FLAG1 )  IST=1 

35  INP<1>»  *  ’ 

ST (3) “1 

CALL  MENUWR ( RC,  4,  3,  3,  INP, 0, 1 , ST) 

CALL  MESS (5, RC (4, 1 ) , RC <4, 2) , RC (4, 3) , 7) 

CLOSE  (SUNITl ) 

CLOSE  (SUNIT2) 

CLOSE  (SUNIT3) 

CLOSE  (SUNIT4) 

GOTO  5 


END 
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SUBROUTINE  SMODdTR,  SUNIT1,  SUN  ITS,  SUNIT2,  SUNIT4,  SFILE1,  SFILES, 

*  SFILE3, SFILE4, SMUNIT, SMFILE) 

C  THIS  SUBROUTINE  MODIFIES  ELEMENTS  FROM  THE  SOURCE-SUBSTANCE  DATA  BASE 

CHARACTER* 1  I NP ( 1 ) , OPT 

'  CHARACTER*40  CINIT1,  CINITS, MKEY (2) 

CHARACTER*8  TEMP (11) 

CHARACTER*?  SFILE1,  SFILE2,  SFILE3, SFILE4, SMFILE 

INTEGER  ITR,  SUNIT1 , SUNIT2, I , SUNIT3, SUNIT4, RC ( 13, 3) , ST (3) , 

*  IERR, ITT, EFLA6 

INTEGER  SINIT1 (10) ,  HD,  HD3(10) 

LOGICAL  FLA61,  FLAG2, FLAG3, FLAG4 

REAL  S2 ( 10) , TDATA ( 1 1 ) , S3 (4) 

")  DATA  ST/0, 0, 0/ 

OPT-’  ’ 

'  >  ITT— 1 

100  MKEY (1) (Ii40)“*  ’ 

MKEY (2) (Ii40)*’  ’ 

105  CALL  MENUSV (SMFILE,  186, RC, 13, SMUNIT) 

IF  (OPT  . EQ.  ’  ** )  THEN 
)  ST (3) -0 

CALL  MENUWR ( RC, 13, 1 , 2, MKEY, 0, 1 , ST) 

GOTO  IS 
END  IF 


C  READ  IN  THE  SUBSTANCE  AND  THE  SOURCE  FROM  THE  MENU 
IST-1 

5  CALL  MENURD (RC,  13,  1ST,  2,  MKEY, ITR) 

C  CHECK  TO  SEE  IF  THE  SUBSTANCE  OR  THE  SOURCE  IS  BLANK 

C  CAN  NOT  GO  ON  IF  EITHER  SUBSTANCE  OR  SOURCE  IS  BLANK 

IF  ( (MKEY(l)  .EQ.  »  »)  .OR.  (MKEY (2)  .  EQ.  »  ’))  THEN 
j  IF  (MKEY (2)  .EQ.  »  ’)  IST-2 

IF  (MKEY ( 1 )  .EQ.  ’  ’)  IST-1 
GOTO  5 

END  IF 

C  SCANNING  THE  COMMAND  INPUT  ROM 
O  15  INP(l)*’  ’ 

CALL  MENURD (RC,  13,  12,  12,  INP, ITT) 

IF  (INP(l)  .EQ.  ’  ’)  THEN 

ST (3) -1 

CALL  MENUWR  ( RC,  13,  12,  12,  INP,0,  1,ST) 

CALL  MESS (4,  RC ( 13, 1 ) ,  RC ( 13, 2) , RC ( 13,  3) ,  1 ) 

IST-1 

GOTO  5 

END  IF 

IF  ( INP ( 1  >  .EQ.  ’X’)  RETURN 
IF  ( INP ( 1 )  .NE.  ’  M’  )  GOTO  15 

C  ALLOW  THE  QUESTION  MARK  TO  BE  ANSWERED 

IF  ( (MKEY(l)  .EQ.  ’  ?» ) . OR.  (MKEY (2)  . EQ.  ’ ?’ ) >  THEN 
INQUIRE  (FILE-SFILE1,  EXI8T-FLAG1 ) 

INQUIRE  (FILE-SFILE2,  EXI8T-FLAG2) 
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IF  <<.NOT.  FLAGD.OR.  (.  NOT.  FLAG2) )  THEN 

CALL  MESS (18,  RC ( 13,  1 > ,  RC ( 13,  2) , RC ( 13,  3) , 7) 

GOTO  15 

END  IF 

IF  (MKEY(l)  .EQ.  ’  ?’ )  THEN 

CALL  SBQST (MKEY,  SUNIT1,  SUNIT2,  SFILE1,  SFILE2, SMUNIT, SMFILE, 

*  ITR, EFLAG) 

IF  (EFLAG  .NE.  0)  THEN 

ST (3) =1 

CALL  MENUWR ( RC, 13, 12,  12,  INP,0,  1,  ST) 

CALL  MESS (5, RC ( 13, 1 ) , RC ( 13, 2> ,  RC ( 13,  3) ,  1) 

IST=2 

GOTO  5 

END  IF 

END  IF 

IF  (MKEY (2)  .EQ.  ’ ?’  )  THEN 

CALL  SRCQST (MKEY,  SUNIT1, SUNIT2,  SFILE1,  SFILE2, SMUNIT, SMFILE, 

*  ITR, EFLAG) 

IF  (EFLAG  .NE.  0)  THEN 

ST (3) =1 

CALL  MENUWR  ( RC,  13,  12,  12,  INP,  0,  1,ST) 

CALL  MESS <5, RC(13, 1 ) , RC ( 13, 2) , RC ( 13,  3),  1) 

IST=1 

GOTO  5 

ENDIF 

END  IF 

OPT=’ &’ 

GOTO  105 

ENDIF 

CHECK  TO  SEE  THAT  ALL  THE  NECESSARY  DATA  BASES  EXIST 
INQUIRE  (FI LE=SF ILE 1 ,  EX I ST»FLAG 1 ) 

INQUIRE  (FILE=SFILE2,  EXIST=FLAG2) 

I NQU IRE  (FI LE=SF I LE3, EX I ST®FLAG3 ) 

INQUIRE  (FILE=SFILE4, EXIST=FLAG4) 

IF  ((.NOT.  FLAG  1).  OR.  (.NOT.  FLAG2) .  OR. 

*  (.NOT.  FLAG3)  .OR.  (.NOT.  FLAG4) )  THEN 

CALL  MESS (18,  RC ( 13,  1 ) , RC ( 13, 2) , RC ( 13, 3) , 7) 
GOTO  15 
ENDIF 


CHECK  TO  SEE  IF  THE  SUBSTANCE  IS  IN  THE  DATA  BASE 
OPEN  (SUNIT1, FILE=SFILE1, STATUS®’  OLD’  , RECL®120, ACCESS®’ DIRECT’ , 
*  FORM®’ UNFORMATTED’  ) 

READ (SUNIT1 , REC®1 )  HD 
DO  20  I®2, HD, 1 

READ(SUNIT1, REC«I)  CINIT1 , SINIT1, S2 
IF  (MKEY ( 1 >  .EQ.  CINIT1)  GOTO  25 
CONTINUE 
IST-1 

INP ( 1 ) ■’  * 

ST (3) ®1 

CALL  MENUWR ( RC, 13, 12, 12,  INP, 0, 1, ST) 

CALL  MESS (5,  RC (13,  1 ) ,  RC ( 13,  2) ,  RC ( 13, 3) , 7) 

CLOSE  (SUNIT1 ) 

GOTO  5 


CHECK  TO  SEE  IF  THE  SOURCE  IS  IN  THE  DATA  BASE 


£5 


OPEN  <SUNIT£, FILE-SFILE2,  STATUS-*  OLD* ,  RECL-40, ACCESS-*  DIRECT’ , 

*  FORM-*  UNFORMATTED’  > 

32  DO  30  11-1,9,1 

IF  (SINIT1 (II)  .  EQ.  0)  SOTO  30 
READ (SUNIT2,  REC-S1NIT1 (II) >  CINIT2 
>  IF  (MKEY (2)  .EQ.  CINIT2)  GOTO  35 

30  CONTINUE 

IF  (SINIT1 ( 10)  .NE.  0)  THEN 
I-SINIT1 ( 10) 

READ (SUNIT1, REC-I)  CINIT1, SINIT1, S2 
SOTO  32 

END  IF 

I  ST-2 
ST (3) -1 

)  INP(l)-’  ’ 

CALL  MENUWR ( RC,  13,  12,  12,  INP,0,  1,ST) 

CALL  MESS (5,  RC ( 13,  1 ) ,  RC (13,  2) ,  RC ( 13,  3) ,  7) 

~)  CLOSE  (SUNIT1) 

CLOSE  (SUNIT2) 

SOTO  5 

O 

35  OPEN  (SUNIT3, FILE-SFILE3, STATUS-’ OLD’ ,  RECL-40, ACCESS-*  DIRECT’ , 

*  FORM-’ UNFORMATTED’  > 

">  OPEN  (SUNIT4, FILE-SFILE4,  STATUS-’ OLD’ , RECL-16, 

*  ACCESS-’ DIRECT’ ,  FORM-’ UNFORMATTED* ) 

READ ( SUN I T3,  REC-I)  HD3 

'l  READ  (SUNIT4,  REC-HD3 (II))  S3 

C  CONVERT  THE  BINARY  DATA  TO  ALPHA  DATA 

'  DO  40  K-3, 7, 1 

WRITE (TEMP (K) (1*8),’ (F8. 3) * )  S2(K-2) 

40  CONTINUE 

DO  41  K-8, 11,1 

WRITE  (TEMP  (K)  (U8),*  (F8.3)’  )  S3(K-7) 

41  CONTINUE 

C  BLANK  OUT  THE  COMMAND  LINE 

ST (3)-l 
INP ( 1 ) — *  » 

CALL  MENUWR(RC,  13,  12,  12,  INP,0,  1,ST> 

.j  C  OUTPUT  THE  STORED  DATA 
ST (3) -0 

CALL  MENUWR (RC,  13,  3,  1 1,  TEMP,  0,  1,  ST) 

U 

I  ST-3 

55  CALL  MENURD(RC,  13,  1ST,  11, TEMP, ITR) 

C  SCANNING  THE  COMMAND  INPUT  ROW 
60  INP  ( 1 )  — ’  ’ 

CALL  MENURD ( RC,  13,  12,  12,  INP, ITT) 

IF  ( INP ( 1 )  .EQ.  ’  ’)  THEN 

IST-3 
ST (3) *1 

CALL  MESS (4, RC ( 13, 1 ) , RC ( 13, 2) , RC ( 13,  3) ,  1 ) 
CALL  MENUWR  (RC, 13, 12, 12, INP,0, 1,ST) 

GOTO  55 
END  IF 

IF  ( INP ( 1 )  .EQ.  ’X’)  THEN 

CLOSE  (SUNIT1) 
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LLUJu  .  I  C.) 

CLOSE  (SUNIT3) 

CLOSE  (SUNIT4) 

OPT=’  &» 

GOTO  100 
END  IF 

IF  (INP(l)  .NE.  »M»  )  GOTO  60 

C  CHECK  THE  REQUEST  FOR  ERRORS 
TEMP ( 1 ) (1:8)*'  » 

TEMP (2) (1:8)=’  » 

CALL  MENUCKtTEMP, TDATA,  11, »  (F8. 3) ’ , IERR) 

IF  (IERR.  NE.  0)  THEN 

INP ( 1 )  ='  * 

)  ST (3) =1 

CALL  MENUWR ( RCf 13,  IE, IE, INP, 0, 1,ST) 

CALL  MESS ( 1, RC ( 13, 1 > , RC ( 13,  S) ,  RC ( 13,  3) ,  7) 

IST=IERR 
GOTO  55 
END  IF 

'i  DO  61  K=3,6,  1 

IF  (TDATA(K)  .LE.  0.0)  THEN 

IST=K 
INP  ( 1 )  =*  * 

ST (3) =1 

CALL  MENUWR (RC, 13, IE, IS, INP, 0, 1,ST) 

CALL  MESS ( 1 , RC ( 13, 1 ) , RC ( 13, £) , RC ( 13, 3) , 7) 
GOTO  55 
END  IF 

61  CONTINUE 

IF  (TDATA (S)  .LE.  0)  THEN 

IST=6 
INP ( 1 )  ='  ’ 

ST (3) =1 

CALL  MENUWR (RC,  13,  IE, IE,  INP, 0, 1,ST> 

)  CALL  MESS (1, RC ( 13, 1), RC ( 13, £) , RC ( 13, 3) ,  7) 

GOTO  55 
END  IF 


c 

LOAD  THE  SS  AND  S3  ARRAYS  WITH  THE  NEW  DATA 
S3(1)=TDATA(8) 

S3 (S) -TDATA (9) 

S3 (3) -TDATA (10) 

S3 (4) -TDATA (11) 

O 

DO  48  K-l, 10, 1 

SS (K) -0.  0 

4E 

CONTINUE 

DO  43  K-l, 5, 1 

SS(K) -TDATA (K+E) 

43 

CONTINUE 

WRITE (SUNIT4, REC-HD3 (II))  S3 

DO  44  I— S,  HD,  1 

READ (SUNIT1,  REC-I )  CINIT1 ,  SINIT1 

IF  (CINIT1  .EQ.  MKEY ( 1 ) )  GOTO  45 

44 

CONTINUE 

45 

WRITE (SUNIT1,  REC-I)  CINIT1, SINIT1, S£ 

80 

IF  (SINIT1 ( 10)  .NE.  0)  THEN 

I-SINITK10) 

READ (SUN I Tl , REC- I )  CINIT1, SINIT1 


149 


WRITE (SUNIT1, REC=I )  CINIT1,  SINIT1,  S2 
GOTO  8G 

END  IF 

CLOSE  (SUNIT1 ) 

CLOSE  (SUNIT2) 

CLOSE  (SUNIT3) 

CLOSE  (SUNIT4) 

OPT5*’  ** 

GOTO  100 

END 

SUBROUTINE  SBQST  (SKEY,  SUNIT1,  SUNIT2, SFILE1, SFILE2, SMUNIT, SMFILE 

ITR, EFLAG) 

CHARACTER*70  OUT ( 19) 

CHARACTER*40  SKEY ( 1 ) ,  HEAD, THEAD, SHEAD 
CHARACTER*7  SF I LE 1 , SF I LE2, SMF I LE 

CHARACTER*3  CMD ( 1 ) 

INTEGER  SUN1T1,  SUNIT2,  SMUNIT, RC (19, 3) , ST (3) , ICNT, ITR, 

EFLAG,  HD,  HDR  (10) 

LOGICAL  FLAG1 

DATA  ST/0,0,0/ 

EFLAG® 1 

OPEN  (SUNIT1,  FILE=SFILE1,  STATUS®’  OLD* , RECL=120, ACCESS®* DIRECT* , 
FORM®’ UNFORMATTED* ) 

OPEN  (SUNIT2,  FILE=SFILE2,  STATUS®*  OLD* ,  RECL=40,  ACCESS®*  DIRECT* , 
FORM®’ UNFORMATTED’  ) 

READ (SUN1T1 , REC®1 >  HD 
ICNT*2 

FLAG 1®. FALSE. 

DO  20  I®2, HD,  1 

IF  (.NOT.  FLAG1 )  FLAG1®.  TRUE. 

READ (SUN IT 1, REC=I)  HEAD,  HDR 
I CHECK® 0 
DO  13  JG»1,9, 1 

IF  (HDR ( JG)  .NE.  0)  ICHECK-1 
CONTINUE 

IF  (ICHECK  .  EQ.  0)  GOTO  20 
IF  (SKEY (2)  .NE.  * ** >  THEN 
IF  (SKEY (2)  .NE.  ’ ?’ >  THEN 
DO  12  K-1,9,  1 

IF  (HDR (K)  .EQ.  0)  GOTO  12 
READ(SUNIT2, REC-III)  SHEAD 
IF  (SHEAD  .EQ.  SKEY (2))  GOTO  11 
CONTINUE 
GOTO  20 

END  IF 
END  IF 

DO  10  J®2, 1-1, 1 

READ ( SUN IT1,REC*J)  THEAD 
IF  (THEAD  .EQ.  HEAD)  GOTO  20 
CONTINUE 
EFLAG-0 

OUT ( ICNT) (li70>-*  ’ 

WRITE (OUT (ICNT) (1*3),* (13)*)  I 
OUT (ICNT) (6i70)»HEAD 


15 


o 


20 


25 


•+J 


o 


ih  ui/Wl  .  tU.  1  3 )  I  HLN 

CALL  MENUSV (SMFILE,  102, RC, 19, SMUNIT) 
CALL  MENUWR(RC,  19,2,  19,  OUT, 0, 1,ST) 
CMD <!)=’’ 


CALL  MENURD (RC,  19,  1,1,  CMD, ITR) 

IF  (CMD(l)  .EQ.  ’X  ’)  THEN 

CLOSE  (SUNIT1 ) 
CLOSE  (SUNIT2) 
RETURN 
END  IF 

IF  (CMD(l)  .EQ.  'C  ’)  THEN 

ICNT=2 

FLAG 1=. FALSE. 

GOTO  20 
END  IF 

READ (CMD ( 1 ) (1:3),’ < 13) ’ , ERR=15)  II 
IF  ((II  .LT.  2). OR. (II  .GT.  HD) >  GOTO  15 
READ (SUNIT1, REC=I I )  SKEY(l) 

CLOSE  (SUNIT1) 

CLOSE  (SUNIT2) 

RETURN 

END  IF 

ICNT=ICNT+1 

CONTINUE 

IF  (EFLAG  .NE.  0)  RETURN 

IF  (.NOT.  FLAG1)  GOTO  5 

CALL  MENUSV (SMFILE,  102,  RC,  19,  SMUNIT) 

CALL  MENUWR (RC, 19,2,  ICNT-1,  OUT, 0, 1,ST) 

CMD ( 1 ) =’  ’ 

CALL  MENURD ( RC, 19,  1,  1,  CMD, ITR) 

IF  ( CMD ( 1 )  .EQ.  ’X  ’)  THEN 

CLOSE  (SUNIT1) 

CLOSE  (SUNIT2) 

RETURN 
END  IF 

IF  (CMD ( 1 )  .EQ.  ’C  ’)  THEN 

FLAS1*=.  FALSE. 

GOTO  5 
END  IF 

READ (CMD ( 1 ) (1:3),’ ( 13) ' , ERR»25>  II 
IF  ((II  .LT.  2). OR. (II  .GT.  HD) >  GOTO  25 
READ(SUNIT1,REC=II)  SKEY(l) 

CLOSE  (SUNITl) 

CLOSE  (SUNIT2) 

RETURN 


END 

SUBROUTINE  SRCQST (SKEY,  SUNITl,  SUNIT2,  SFILE1, SFILE2, SMUNIT, SMFILE, 
*  ITR, EFLAG) 


CHARACTER*70 

CHARACTER*40 

CHARACTER*? 

CHARACTER*3 


OUT (19) 

SKEY ( 1 ) ,  HEAD,  THEAD,  SHEAD 
SFILE1, SFILE2, SMFILE 
CMD ( 1 ) 


INTEGER  SUNITl,  SUNIT2,  SMUNIT,  RC ( 19,  3) ,  ST (3) ,  ICNT,  ITR, 

»  EFLAG, HD,  HD 1 


INTEGER  HDR(10) 
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LOGICAL 


FLAG1 


DATA  ST/0,0,0/ 

EFLAG-1 

OPEN  (SUNIT1, FILE-SFILE1,  STATUS-* OLD* , RECL-120, ACCESS-’ DIRECT* , 

*  FORM-*  UNFORMATTED* ) 

OPEN  (SUNIT2, FILE-SFILE2,  STATUS-’  OLD* , RECL-40, ACCESS-’ DIRECT* , 

*  FORM-’  UNFORMATTED* ) 

READ ( SUN ITS, REC- 1 )  HD 

5  ICNT-2 

FLAG1-.  FALSE. 

DO  20  1-2, HD,  1 

IF  (.NOT.  FLAG1)  FLAG1-.  TRUE. 

READ (SUN I T2, REC- I)  SHEAD 
IF  (SKEY(l)  .NE.  *#’)  THEN 

IF  (SKEY(l)  .NE.  *?»)  THEN 

READ (SUNIT1, REC- 1)  HD1 
DO  12  K-2, HD1, 1 

READtSUNITl, REC-K)  HEAD, HDR 
IF  (HEAD  .NE.  SKEY(1>)  GOTO  12 
DO  13  KK-1, 9, 1 

IF  (HDR(KK)  .  Ed.  I)  GOTO  11 
13  CONTINUE 

12  CONTINUE 

GOTO  20 

END  IF 
ENDIF 

1 1  EFLAG-0 

OUT ( ICNT)  (1*70) -»  » 

WRITE (OUT ( ICNT) (li3),* (I3>* >  I 
OUT (ICNT) (6 i 70) -SHEAD 
IF  (ICNT  . EQ.  19)  THEN 

CALL  MENUSV (SMFILE, 183, RC, 19, SMUNIT) 

CALL  MENUWR(RC,  19, 2, 19, OUT, 0,  1, ST) 

15  CMD(l)-*  » 

CALL  MENURD(RC, 19, 1, 1, CMD, ITR) 

IF  (CMD ( 1 )  .EQ.  *X  *)  THEN 

CLOSE  (SUNIT1) 

CLOSE  (SUNIT2) 

RETURN 

ENDIF 

IF  (CMD ( 1 )  .EQ.  *C  »)  THEN 

ICNT-2 

FLAG1-. FALSE. 

GOTO  20 
ENDIF 

READ (CMD ( 1 ) (1 13) , * (13)’ , ERR-15)  II 
IF  ((II  .LT.  2). OR.  (II  .GT.  HD))  GOTO  15 
READ (SUN ITS, REC-II)  SKEY(2) 

CLOSE  (SUNIT1) 

CLOSE  (SUNIT2) 

RETURN 

ENDIF 

ICNT-ICNT+1 
20  CONTINUE 

IF  (EFLAG  .NE.  0)  RETURN 

IF  (.NOT.  FLAG1)  GOTO  5 

CALL  MENUSV (SMFILE, 183, RC,  19,  SMUNIT) 

CALL  MENUUR(RC, 19,2,  ICNT-1, OUT, 0, 1,ST> 
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CMD ( 1 )  -’  » 

CALL  MENURD(RC,  19,  1,1,  CMD,  ITR) 

IF  (CMD  ( 1 )  .EQ.  ’X  ’)  THEN 

CLOSE  ( SUN I T 1 ) 
CLOSE  (SUNIT2) 
RETURN 
END  IF 

IF  (CMD ( 1 )  .EQ.  *C  *  )  THEN 

FLAG1=. FALSE. 

SOTO  5 
END  IF 

READ(CMDU)  (1:3),*  ( 13) » , ERR=25)  II 
IF  ((II  .LT.  2).  OR.  (II  .GT.  HD)  >  GOTO  25 
READ (SUNIT2,  REC=I I )  SKEY(2) 

CLOSE  (SUNITl) 

CLOSE  (SUNIT2) 

RETURN 

END 
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(The  reverse  of  this  pegs  is  blank) 


